perm filename LISP.MAC[RUT,LSP] blob
sn#343764 filedate 1978-03-22 generic text, type T, neo UTF8
00010 TITLE LISP INTERPRETER (RUTGERS/UCI VERSION)
00020 SUBTTL NOTES TO SYSTEM PROGRAMMERS
00030
00040 ; COMMENTS:
00050 ;
00060 ; THERE ARE BASICALLY THREE SETS OF COMMENTS IN THE CODE:
00070 ; THOSE IN LOWER CASE ARE ORIGINAL STANFORD COMMENTS;
00080 ; THOSE OF A SEMI-COLON FOLLOWED BY TWO $'S,
00090 ; TWO #'S, OR TWO %'S ARE UCI ADDITIONS,
00100 ; CHANGES, OR ADDITIONAL COMMENTS
00110 ; ($'S ARE USUALLY DARYLE LEWIS,
00120 ; #'S ARE GENERALLY JEFF JACOBS,
00130 ; AND %'S ARE GENERALLY BILL EARL).
00140 ;** ** COMMENTS ARE RUTGERS MODIFICATIONS (RICK LEFAIVRE)
00150 ;** [UT] COMMENTS ARE ADDITIONS FROM TEXAS (MABRY TYSON
00160 ;** AND RICH COHEN), APPROPRIATED BY RICK LEFAIVRE
00170
00180 ;** WARNING: Note that the RUCI LISP Compiler makes various assumptions
00190 ;** about the register usage of many of the (smaller) functions in
00200 ;** LISP.MAC. If you make any changes regarding register allocations,
00210 ;** make sure you check the compiler.
00220
00230 ;%% VERSION DEFINITIONS:
00240
00250 LSPWHO==3 ;** RUTGERS
00260 LSPVER==10 ;%% MAJOR VERSION
00270 LSPMIN==6 ;%% MINOR VERSION
00280 LSPEDT==1 ;%% EDIT LEVEL
00290
00300 ; ASSEMBLY SWITCHES OF INTEREST:
00310 ;
00320 ; SWITCH EXPLANATION, COMMENTS ETC.
00330 ; ------ ----------------------------
00340 ; ALTMOD FOR ALTMODE CHARACTER. OLD WAS 175
00350 ; NOW IT'S 33 FOR 506
00360 ; QALLOW ENABLES ACCESS TO QMANGR, ONLY IF YOUR
00370 ; SYSTEM SUPPORTS QUEUE. SEVERAL SWITCHES
00380 ; ASSOCIATED WITH THE CODE
00390 ;** OLDNIL OLD STANFORD NIL. IF OFF CAR AND CDR OF
00400 ; NIL ARE NIL A LA INTERLISP
00410 ; NONUSE OLD STANFORD VERSIONS OF MEMQ, AND ETC.
00420 ; THAT RETURNED T OR NIL.
00430 ; REALLC PROGRAM-CONTROLLED DYNAMIC REALLOCATION
00440 ; ROUTINE AND RELATED FUNCTIONS
00450 ; SYSPRG PROJECT NUMBER IF NOT ON SYS:.
00460 ; SYSPN PROGRAMMER NUMBER IF NOT ON SYS:
00470 ; SYSDEV DEVICE LOCATION OF SYSTEM.
00480 ;%% SYSNAM NAME OF EXPECTED HIGH SEGMENT
00490 ;%% AND LISP LOADER AND SYMBOL TABLE
00500 ;%% INUMIN LOWEST ADDRESS AVAILABLE FOR USE AS
00510 ;%% AN INUM
00520 ;%% BCKETS NUMBER OF HASH BUCKETS
00530 ;%% SHRST LOWEST ADDRESS IN HIGH SEGMENT
00540 ;** SPRNT SYSTEM-SUPPLIED SPRINT
00550 ;** PNAMES INSERT PNAMES OF COMPILED LISP SYSTEM
00560 ;** PACKAGES INTO HIGH SEGMENT
00570 ;[UT] RANDOM INCLUDE RANDOM I/O FUNCTIONS
00580 ;[UT] SFDFLG INCLUDE SFD CAPABILITY
00590
00600
00610 ; **USE FOLLOWING AT OWN RISK**
00620
00630 ; HASH NUMBER OF HASH BUCKETS WHEN STARTING
00640 ; ALVINE STANFORD EDITOR (WHO WOULD WANT IT?)
00650 ; 1 FOR ALVINE, 0 FOR NO ALVINE
00660 ; STPGAP ANOTHER STANFORD EDITOR
00670 ;** BIGNMS BIGNUM PACKAGE (IF ON NORMAL INTEGERS ARE
00680 ;** REDUCED FROM 36 TO 35 SIG. BITS FOR I/O)
00690
00700 PAGE
00710 SUBTTL AC DEFINITIONS, SWITCHES, AND EXTERNALS
00720
00730 IFNDEF SHRST <SHRST==400000> ;[1]
00740
00750 TWOSEG SHRST ;[1]
00760
00770 IFNDEF OLDNIL <OLDNIL==0> ;** NEW NIL COMPLETED 8/76
00780 IFNDEF NONUSE <NONUSE==0> ;** DON'T WANT OLD MEMB, ETC.
00790 IFN SHRST-400000 <QALLOW==0>
00800 IFNDEF QALLOW <QALLOW==0> ;** DEFAULT IS NO QUEUE
00810 IFNDEF REALLC <REALLC==1> ;** DEFAULT IS TO INCLUDE
00820 IFNDEF SPRNT <SPRNT==0> ;** USE SPRINT IN PP PACKAGE
00830 IFNDEF PNAMES <PNAMES==1> ;** PNAMES IN HIGH SEGMENT
00840 IFNDEF RANDOM <RANDOM==1> ;[UT] INCLUDE RANDOM I/O
00850 IFNDEF SFDFLG <SFDFLG==1> ;[UT] INCLUDE SFD CAPABILITY
00860
00870 IFNDEF SYSPRG <SYSPRG==0 ;** LOC. OF HIGH SEGMENT
00880 SYSPN==0>
00890 IFE SYSPRG,<IFNDEF SYSDEV,<DEFINE SYSDEV <SIXBIT /SYS/>>>
00900 IFN SYSPRG,<IFNDEF SYSDEV,<DEFINE SYSDEV <SIXBIT /DSK/>>>
00910 IFNDEF SYSNAM,<DEFINE SYSNAM <SIXBIT /LISP/>> ;**
00920
00930 IFNDEF ALVINE <ALVINE==0> ;** DON'T WANT ALVINE
00940 IFNDEF HASH <HASH==0> ;** KEEP HASH SIZE FIXED
00950 IFNDEF STPGAP <STPGAP==0> ;** DON'T WANT SOS INTERFACE
00960 IFNDEF BIGNMS <BIGNMS==0> ;** DON'T WANT BIGNUMS
00970
00980 IFNDEF INUMIN <INUMIN=SHRST-1> ;%% [1]
00990 INUM0=777777-<<777777-INUMIN>/2> ;%% [1]
01000 IFNDEF BCKETS <BCKETS==177>
01010
01020 IF1,<PURGE CDR,DF>
01030 PAGE
01040 ;accumulator definitions
01050 ;`sacred' means sacred to the interpreter
01060 ;`marked' means marked from by the garbage collector
01070 ;`protected' means protected during garbage collection
01080
01090 NIL=0 ;sacred, marked, protected ;atom head of NIL
01100 A=1 ;marked, protected ;results of functions and first arg of subrs
01110 B=A+1 ;marked, protected ;second arg of subrs
01120 C=B+1 ;marked, protected ;third arg of subrs
01130 AR1=4 ;marked, protected ;fourth arg of subrs
01140 AR2A=5 ;marked, protected ;fifth arg of subrs
01150 T=6 ;marked, protected ;minus number of args in LSUBR call
01160 TT=7 ;marked, protected
01170 REL=10 ;marked, protected
01180 S=11 ;$$NOW USED FOR ATOM RELOCATION AND GARBAGE COLLECTOR
01190 D=12
01200 R=13 ;protected
01210 P=14 ;sacred, protected ;regular push down stack pointer
01220 F=15 ;sacred ;free storage list pointer
01230 FF=16 ;sacred ;full word list pointer
01240 SP=17 ;sacred, protected ;special pushdown stack pointer
01250
01260 NACS==5 ;number of argument acs
01270
01280 X==0 ;X indicates impure (modified) code locations (** Obsolete)
01290 TEN==↑D10
01300
01310 ;UUO definitions
01320
01330 ;UUOs used to call functions from compiled code
01340 ;the number of arguments is given by the ac field
01350 ;the address is a pointer either to the function
01360 ;name or the code of the function
01370 OPDEF FCALL [34B8] ;ordinary function call-may be changed to PUSHJ
01380 OPDEF JCALL [35B8] ;terminal function call-may be changed to JRST
01390 OPDEF CALLF [36B8] ;like call but may not be changed to PUSHJ
01400 OPDEF JCALLF [37B8] ;like jcall but may not be changed to JRST
01410
01420 ;error UUOs (** Modified for interface with smart ERRORX)
01430 OPDEF ERR1 [1B8] ;"correctable" lisp error; message can be suppressed
01440 OPDEF ERR2 [2B8] ;"serious" lisp error; no message suppression
01450 OPDEF ERR3 [3B8] ;space overflow error; no break to ERRORX
01460 OPDEF ERR4 [4B8] ;ill. mem. ref.; "serious" error with special print
01470 OPDEF STRTIP [5B8] ;print error message and continue
01480
01490 ;system UUOs
01500 OPDEF INCHRW [TTCALL 0,]
01510 OPDEF OUTCHR [TTCALL 1,]
01520 OPDEF OUTSTR [TTCALL 3,]
01530 OPDEF INCHWL [TTCALL 4,]
01540 OPDEF INCHSL [TTCALL 5,]
01550 OPDEF GETLCH [TTCALL 6,]
01560 OPDEF SETLCH [TTCALL 7,]
01570 OPDEF CLRBFI [TTCALL 11,]
01580 OPDEF SKPINC [TTCALL 13,]
01590 OPDEF SKPINL [TTCALL 14,] ;## BETTER FOR TALK THAN SKPINC
01600 OPDEF TALK [PUSHJ P,TTYCLR+1] ;## TURN OFF CONTROL O
01610
01620 ;I/O bits and constants
01630 TTYLL==110 ;teletype linelength
01640 LPTLL==160 ;line printer linelength
01650 MLIOB==203 ;max length of I/O buffer
01660 IFE RANDOM,<NIOB==2> ;no of I/O buffers per device
01670 IFN RANDOM,<NIOB==1 ;[UT]
01680 BFCHRS==1200> ;[UT] # OF CHARS IN A BUFFER
01690 NIOCH==17 ;number of I/O channels
01700 FSTCH==1 ;first I/O channel
01710 TTCH==0 ;teletype I/O channel
01720 IFE SFDFLG,<SFDLEN==0> ;[UT]
01730 IFN SFDFLG,<SFDLEN==5> ;[UT] DEPTH OF SFD NESTING
01740 BLKSIZE==NIOB*MLIOB+COUNT+1
01750 INB==2
01760 OUTB==1
01770 AVLB==40
01780 DIRB==4
01790
01800 ;channel data
01810 CHNAM==0 ;name of channel
01820 IFE RANDOM,<CHDEV==CHNAM+1> ;name of device
01830 IFN RANDOM,<CHBUFS==CHNAM+1 ;[UT] NUMBER OF BUFFER LOADS
01840 CHDEV==CHBUFS+1>
01850 CHFILE==CHDEV+1 ;[UT] NAME OF FILE
01860 CHEXT==CHFILE+1 ;[UT] EXTENSION
01870 CHPPN==CHEXT+1 ;ppn for input channel
01880 CHLL==CHEXT+1 ;linelength for output channel
01890 CHHP==CHLL+1 ;hposit for output channels
01900 CHOCH==CHPPN+1+SFDLEN ;oldch for input channels
01910 IFN STPGAP,<
01920 CHPAGE==CHOCH+1 ;page number for input
01930 CHLINE==CHPAGE+1 ;line number for input
01940 CHDAT==CHLINE+1 ;device data
01950 >
01960 IFE STPGAP,<
01970 CHDAT==CHOCH+1
01980 >
01990 ;[UT] CHDAT,POINTR,COUNT MUST BE CONSECUTIVE FOR I/O
02000 POINTR==CHDAT+1 ;byte pointer for device buffer
02010 COUNT==POINTR+1 ;character count for device buffer
02020
02030 ;special ASCII characters
02040 IFNDEF ALTMOD,<ALTMOD==33>
02050 SPACE==40 ;space
02060 DBLQT==42 ;"
02070 IGCRLF==31 ;ignored cr-lf (** ↑Y)
02080 RUBOUT==177
02090 LF==12
02100 CR==15
02110 TAB==11
02120 BELL==7
02130
02140 ;** ↑C interrupt chars
02150 CNTLH==10
02160 CNTLE==5
02170 CNTLB==2
02180 CNTLZ==32
02190 CNTLG==7
02200 CNTLR==22
02210 CNTLD==4
02220 CNTLX==30
02230 CNTLF==6
02240 QMARK==77
02250
02260 ;byte pointer field definitions
02270 ACFLD==14 ;ac field
02280 XFLD==21 ;index field
02290 OPFLD==10 ;opcode field
02300 ADRFLD==43 ;adress field
02310
02320 ;Addresses in Job Data Area
02330 .JBUUO==40
02340 .JB41==41
02350 .JBREL==44
02360 .JBHRL==115
02370 .JBSYM==116
02380 .JBSA==120
02390 .JBFF==121
02400 .JBPFH==123
02410 .JBREN==124
02420 .JBAPR==125
02430 .JBCNI==126
02440 .JBTPC==127
02450 .JBOPC==130
02460 .JBINT==134
02470 .JBVER==137
02480
02490 ;apr flags
02500 PDOV==200000 ;push down list overflow
02510 MPV==20000 ;memory protection violation
02520 NXM==10000 ;non-existant memory referenced
02530 APRFLG==PDOV+MPV+NXM ;any of the above
02540
02550 ;system uuos
02560 APRENB==16
02570 RESET==0
02580 RUNTIM==27
02590 DEVCHR==4
02600 DEVPPN==55
02610 EXIT==12
02620 CORE==11
02630 SETUWP==36
02640 GETSEG==40
02650 DATE==14
02660 MSTIME==23
02670 PJOB==30
02680 HIBER==72
02690 PATH.==110
02700 TRMNO.==115
02710 TRMOP.==116
02720 .TOSOP==2
02730 .TOHPS==1011
02740
02750 ;REMOTE MACRO
02760 ;[UT] BETTER REMOTE MACRO:
02770
02780 DEFINE REMOTE (TX)
02790 < RELOC
02800 XALL
02810 TX
02820 SALL
02830 RELOC
02840 >
02850
02860 ;[UT] OLD REMOTE MACRO:
02870 COMMENT &
02880 DEFINE REMOTE (TX)
02890 < HERE1 <TX>>
02900
02910 DEFINE HERE1 (NEW,OLD,%G)
02920 < DEFINE %G
02930 < NEW>
02940 DEFINE REMOTE (TX)
02950 < HERE1 <TX>,<OLD
02960 %G
02970 >>>
02980 DEFINE HERE
02990 < DEFINE HERE1 (XX,YY)
03000 < YY>
03010 REMOTE>
03020 & ;[UT] END OLD REMOTE MACRO
03030
03040 SALL
03050 PAGE
03060 SUBTTL START, EXIT, AND ↑C TRAP ROUTINES
03070
03080 ;** Through STRT is all new as of 10/10/76 - RAL
03090
03100 ;** Set up memory locations in Job Data Area
03110 LOC .JB41
03120 JSR UUOH
03130 LOC .JBSA
03140 XWD X,START ;(Must be reset since clobbered by initial load)
03150 LOC .JBREN
03160 XWD 0,REENTR
03170 LOC .JBAPR
03180 XWD 0,APRINT ;(Reset at STRT just in case)
03190 LOC .JBINT
03200 XWD 0,CCBLK ;(Ditto)
03210 LOC .JBVER
03220 BYTE (3)LSPWHO (9)LSPVER (6)LSPMIN (18)LSPEDT
03230
03240 RELOC 0
03250 RELOC SHRST
03260
03270 REMOTE<
03280 ;** REENTER Entry Point (Same as START)
03290 REENTR:
03300 ;** START Entry Point
03310 START: SKIPE GCFLAG ;DID HE SOMEHOW GET OUT WHILE GCING?
03320 JRST @.JBOPC ;YES: JUST CONTINUE
03330 SKIPE CCFLAG ;DID HE SOMEHOW GET OUT WITHOUT EXITING?
03340 JRST .+4
03350 PUSH P,.JBOPC ;YES: SIMULATE A ↑C INTERRUPT
03360 POP P,CCBLK+2
03370 JRST CCINT
03380 CALLI RESET ;NORMAL EXIT - DO A RESTART
03390 MOVEI 0,ALLOC
03400 MOVEM 0,CCFLAG ;SET STARTING ADDRESS
03410 START1: MOVSI 0,1
03420 CALLI 0,CORE ;REMOVE OLD HI-SEG IF STILL AROUND
03430 HALT
03440 MOVEI 0,HGHDAT
03450 CALLI 0,GETSEG ;GET SHARABLE HI-SEG
03460 HALT
03470 JRST START2 ;AND CONTINUE IN HI-SEG
03480
03490 ;** Location of sharable high segment. Changed via SETSYS.
03500 HGHDAT: SYSDEV
03510 SYSNAM
03520 0
03530 0
03540 XWD SYSPRG,SYSPN
03550 0
03560 >
03570
03580 START2: MOVSI 17,ACCUMS ;RESTORE ACCUMS
03590 BLT 17,17
03600 SETZM CCBLK+2 ;ENABLE ↑C INTERRUPT TRAPPING
03610 JRST CCCONT ;AND EITHER CONTINUE OR ALLOC
03620
03630 ;** ↑C INTERRUPT HANDLER
03640 CCINT: SKIPE GCFLAG ;GARBAGE COLLECTING?
03650 JRST GCING ;YES: FINISH UP FIRST
03660 SKIPE CCFLAG ;ALREADY INTERRUPTED?
03670 JRST .+3 ;YES: ALREADY SAVED CONTINUE ADDR
03680 MOVE 0,CCBLK+2 ;NO
03690 MOVEM 0,CCFLAG ;SAVE CONTINUE ADDRESS
03700 SETZM CCBLK+2 ;RE-ENABLE ↑C TRAPPING
03710 CCINT1: OUTSTR [ASCIZ /
03720 Interrupt (Help=?): /]
03730 INCHRW 0 ;READ THE INTERRUPT CHARACTER
03740 XCT OCR ;GIVE HIM A CR/LF
03750 CLRBFI ;CLEAR ANY GARBAGE OUT
03760 CAIN 0,CNTLR ;↑R
03770 JRST [HRRI 0,OBTBL(S)
03780 HRRM 0,VOBLIST(S)
03790 OUTSTR [ASCIZ /OBLIST Restored/]
03800 JRST CCINT1]
03810 CAIN 0,CNTLH ;↑H
03820 JRST [MOVEI 0,TRUTH(S) ;(↑H <-- T)
03830 MOVEM 0,ERINT(S)
03840 JRST CCCONT]
03850 CAIN 0,CNTLE ;↑E
03860 JRST [MOVE 0,STNIL
03870 MOVEI 1,NIL
03880 SETZM CCFLAG
03890 JRST ERR]
03900 CAIN 0,CNTLB ;↑B
03910 JRST [MOVEI 0,TRUTH(S) ;(↑H <-- T)
03920 MOVEM 0,ERINT(S)
03930 MOVE 0,STNIL
03940 SETZM CCFLAG
03950 PUSHJ P,SPDLPT
03960 PUSHJ P,SPREDO
03970 JRST STRT]
03980 CAIN 0,CNTLD ;↑D (CHANGED FROM ↑Z)
03990 JRST [MOVE 0,STNIL
04000 SETZM CCFLAG
04010 JRST STRT]
04020 CAIN 0,CNTLG ;↑G
04030 JRST DOCTLG
04040 CAIN 0,CNTLX ;↑X
04050 JRST [MOVE 0,STNIL ;RETURN TO MONITOR
04060 JRST DOEX1]
04070 CAIN 0,CR ;CR
04080 JRST CCCONT ;IGNORE ↑C
04090 CAIE QMARK ;?
04100 JRST CCINT1 ;UNRECOGNIZED - GO TRY AGAIN
04110 OUTSTR HLPMSG ;GIVE HIM SOME CLUES
04120 TALK ;(IN CASE HE ↑O'S THE MESSAGE)
04130 JRST CCINT1
04140 PFHINT: OUTSTR [ASCIZ /PFH Interrupted - Can't Continue
04150 /]
04160 DOCTLG: MOVE 0,STNIL
04170 SETZM CCFLAG
04180 JRST TTYERC
04190 HLPMSG: ASCIZ /
04200 CR = Continue (Ignore ↑C)
04210 ↑D = Return to Top Level
04220 ↑X = Exit to Monitor via (EXIT NIL)
04230 ↑H = Break Next Fn Call
04240 ↑B = Back Up and Break Last Fn Call
04250 ↑G = (ERR 'ERRORX)
04260 ↑E = (ERR NIL)
04270 ↑R = Restore System OBLIST
04280 /
04290 REMOTE<
04300 GCFLAG: 0 ;(In page 0 because of PFH problem)
04310 CCFLAG: 0 ;(Ditto)
04320 CCBLK: XWD 4,CCINT ;Interrupt Block (also in page 0)
04330 XWD 0,102 ;For ↑C and wierd errors
04340 0 ;PC Goes Here
04350 X ;Other Junk Goes Here
04360 >
04370
04380 ;** CONTINUE AFTER ↑C
04390 ;The kludge for the PFH is to protect against the case when the PFH is
04400 ;interrupted and the trap handler causes another page fault which clobbers
04410 ;the state of the PFH. This could conceivably be fixed by moving everything
04420 ;the ↑C trap handler references into page 0 and not shrinking CORE on a
04430 ;↑X, but one could not reference the stack either, which means a nested
04440 ;↑C at the wrong time could then screw you up. My "solution" was simply
04450 ;to not allow the computation to continue if the PFH is interrupted. The
04460 ;rationale for this is that most uses of ↑C are for the ↑D, ↑G, or ↑X cases
04470 ;anyway, and these will still work correctly when paging. DEC will
04480 ;hopefully fix the problem by not recognizing a ↑C interrupt until after
04490 ;the PFH has completed (but don't hold your breath).
04500 CCCONT: HRRZ 0,.JBPFH ;GET START ADDRESS OF PAGE FAULT HANDLER
04510 JUMPE 0,CCCNT1 ;NONE - ALL IS OK
04520 CAMG 0,CCFLAG ;WAS THE INTERRUPT IN THE PFH?
04530 JRST PFHINT ;YES - ↑G INSTEAD OF CONTINUE
04540 CCCNT1: MOVE 0,STNIL ;RESTORE 0
04550 PUSH P,CCFLAG ;ALLOWS ANOTHER ↑C TO COME ALONG
04560 SETZM CCFLAG
04570 POPJ P,
04580
04590 ;** ↑C HIT WHILE GARBAGE COLLECTING
04600 ; (This should not cause any page faults because of PFH problem)
04610 GCING: MOVEM A,ACCUMS ;SAVE A TEMPORARILY
04620 AOS A,CCFLAG ;INCR # OF INTERRUPTIONS THIS GC
04630 CAIL A,5 ;IF HE REALLY WANTS OUT KILL GC
04640 JRST KILLGC ;(PRIMARILY PROTECTION AGAINST GC BUGS)
04650 ;OTHERWISE PRINT MESSAGE,
04660 OUTSTR [ASCIZ /
04670 Garbage Collecting . . ./]
04680 MOVE A,CCBLK+2 ;GET CONTINUE ADDRESS
04690 MOVEM A,ACCUMS+1 ;SAVE TEMPORARILY
04700 MOVE A,ACCUMS ;RESTORE A
04710 SETZM CCBLK+2 ;RE-ENABLE INTERRUPTS
04720 JRST @ACCUMS+1 ;AND CONTINUE (HOPE NO ↑C JUST BEFORE THIS!)
04730
04740 ;** EXIT Function - This and ↑X interrupt are only legal ways to leave LISP
04750 ;** (EXIT T) = Keep High Segment
04760 ;** (EXIT NIL) = Remove High Segment
04770 DOEXIT: POP P,CCFLAG ;SAVE RETURN (SIMULATING ↑C)
04780 JUMPN A,DOEX2
04790 JRST DOEX1
04800 REMOTE<
04810 DOEX1: SETOM CCBLK+2 ;DISABLE ↑C TRAPPING IF NO HI-SEG AROUND
04820 MOVSI 0,1
04830 CALLI 0,CORE ;REMOVE HI-SEGMENT
04840 HALT
04850 DOEX2: MOVEI 0,ACCUMS ;SAVE ACCUMS
04860 BLT 0,ACCUMS+17
04870 CALLI 1,EXIT
04880 JRST START1 ;GO CONTINUE IF HE CONT'S
04890
04900 ACCUMS: BLOCK 20 ;ROOM FOR ACCS
04910 >
04920 PAGE
04930 SUBTTL INITIALIZATION AND TOP LEVEL
04940
04950 STRT: MOVEI APRINT ;random initializations for lisp interupts
04960 ;** RESET removed so files can stay open
04970 MOVEM .JBAPR
04980 MOVEI APRFLG
04990 CALLI APRENB
05000 MOVEI CCBLK ;** SET ↑C TRAP LOC
05010 HRRM .JBINT
05020 SETZM CCBLK+2
05030 SETZM CCFLAG
05040 SETZM GCFLAG
05050 CALLI A,PJOB ;** GET JOB #
05060 CALLI A,TRMNO. ;** GET UDX FOR CONTROLLING TERMINAL
05070 JRST .+1
05080 MOVEM A,TRMTAB+1 ;** SAVE UDX FOR TALK AND CHRCT
05090
05100 IFN ALVINE,<SETZ PSAV1>
05110 MOVE S,ATMOV ;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
05120 MOVE P,C2# ;initial reg pdl ptr
05130 MOVE B,SC2
05140 PUSHJ P,UBD ;unbind specpdl
05150
05160 ;** #%PROMPTS%# and #%IOCHANS%# now combined in #%BKSAVE
05170 SETZM BKSAVE(S) ;$$CLEAR VARS FOR BREAK PACKAGE (#%BKSAVE)
05180 MOVEI A,INUM0
05190 MOVEM A,BINDNT(S) ;(#%INDENT)
05200
05210 SETZM ERINT(S) ;$$TURN OFF INTERRUPT FLAG (** ↑H)
05220 SETOM ERRSW ;print error messages
05230 SETZM ERRTN# ;return to top level on errors
05240 SETOM PRVCNT# ;initialize counter for errio
05250 MOVE A,LSPRMP ;$$INITIALIZE TO TOP LEVEL PROMPT
05260 PUSHJ P,PROMPT ;$$CAN BE CHANGED BY INITPROMPT
05270 SETZM SMAC ;$$CLEAR SPLICE LIST (JUST IN CASE)
05280 SETZM OLDCH ;**DITTO FOR OLDCH
05290 IFN OLDNIL <HRROI 0,CNIL2(S)> ;INITIALIZE NIL
05300 IFE OLDNIL <SETZ 0, >
05310 MOVEM 0,STNIL# ;** SAVE FOR RESTORATION AFTER ↑C
05320 IFE OLDNIL <MOVEI A,FAKNIL(S) ;** GET FAKE ATOM HEADER OF NIL
05330 MOVEM A,NILHD#> ;** AND SAVE IT FOR GC
05340 IFN HASH <SKIPE HASHFG#
05350 JRST REHASH ;rehash if necessary>
05360
05370 PUSHJ P,TTYRET ;(outc nil t)(inc nil t)return output for gc message
05380 PUSHJ P,LINES0 ;** GET TO NEW LINE BEFORE INITS CALLED
05390 SKIPN F
05400 PUSHJ P,GC ;garbage collect only if necessary
05410 ;** Changed from AGC so stuff in ACs not marked
05420 SKIPE GOBF# ;garbaged oblist flag
05430 STRTIP [SIXBIT /GARBAGED OBLIST←!/]
05440 SETZM GOBF
05450 SKIPE BPSFLG#
05460 JRST BINER2 ;binary program space exceeded by loader
05470 SKIPN BSFLG# ;initial bootstrap for macros
05480 JRST BOOTS
05490 SKIPE A,INITF
05500 CALLF (A) ;evaluate initialization function
05510 PUSHJ P,TTYRET ;return all i/o to tty
05520
05530 ;** LISP TOP LEVEL **
05540 LISP1: MOVE S,ATMOV# ;$$MAKE SURE REL STAYS
05550 ;$$SET UP - BELT AND SUSPENDERS TECHNIQUE
05560 MOVEI A,INUM0+1 ;**
05570 PUSHJ P,LINES ;** GIVE HIM ONE BLANK LINE
05580 PUSHJ P,READ
05590 PUSHJ P,EVAL
05600 PUSH P,A ;** SAVE VALUE JUST OBTAINED
05610 PUSHJ P,LINES0 ;** MAKE SURE AT START OF LINE
05614 MOVEI NACS,1 ;** PUT NIL INTO ARG REGS FOR PRINFN
05618 BLT NACS,NACS ;**
05620 POP P,A ;** RETRIEVE VALUE
05630 CALLF 1,@VPRNFN(S) ;** AND PRINT IT USING %PRINFNTOP
05640 JRST LISP1
05650
05660 INITFL: EXCH A,INITF1# ;## NEW INIT FILE LIST
05670 POPJ P, ;## RETURN THE OLD ONE
05680
05690 INITFN: EXCH A,INITF#
05700 POPJ P,
05710
05720 .RSET: EXCH A,RSTSW#
05730 POPJ P,
05740
05750 COMMENT %
05760 ;## OLD BOOTSTRAP CODE FOR INIT FILE, REPLACED BELOW
05770 ;BOOTSTRAPPER FOR USER'S INIT FILE
05780 BOOTS: SETOM BSFLG
05790 MOVE A,[POINT 7,[ASCII /(ERRSET[INC(INPUT DSK:(INIT.LSP]NIL)[(EVAL(READ]/]]
05800 MOVEM A,BOOPT#
05810 MOVEI A,BSTYI
05820 PUSHJ P,READP1
05830 PUSHJ P,EVAL
05840 JUMPE A,BOOTOT
05850 MOVEI A,BSTYI
05860 PUSHJ P,READP1
05870 PUSH P,A
05880 MOVE A,(P)
05890 PUSHJ P,ERRSET
05900 CAIE A,$EOF$(S)
05910 JRST .-3
05920 BOOTOT: PUSHJ P,EXCISE
05930 JRST ERR
05940
05950 BSTYI: ILDB A,BOOPT
05960 POPJ P,
05970 %
05980
05990 ;## NEW IMPROVED BOOTSTRAPPER FOR USER'S INITFILE(S)
06000 ;## ALLOWS MORE THAN ONE FILE. FIRST FILE IS READ IN
06010 ;## OR IF NOT FOUND BEHAVES AS BEFORE (I.E. NO ERROR MESSAGE)
06020 ;## REMAINING FILES WILL CAUSE AN ERROR MESSAGE IF NOT FOUND.
06030 ;## THUS IF THE USER IS USING THIS TO REALLY SET UP HIS OWN
06040 ;## SYSTEM, HE WILL KNOW ABOUT A FAILURE, BUT THE FIRST
06050 ;## FILES EXISTENCE IS STILL OPTIONAL
06060
06070 BOOTS: SETOM BSFLG# ;## INDICATE BOOTSTRAP DONE
06080 SKIPN T,INITF1# ;## GET INIT FILE LIST IF IT EXISTS
06090 JRST BOOTOT ;## NOPE, EXCISE AND RETURN
06100 MOVEI A,TRUTH(S) ;## USE CHANNEL T
06110 PUSHJ P,INPUT2 ;## SET UP
06120 PUSHJ P,ININIT ;## LOOK UP
06130 JUMPN A,BOOTOK ;## IT'S THERE, GO TO IT
06140 JUMPE T,BOOTOT ;## NOT THERE AND NO OTHERS REQUESTED
06150 PUSHJ P,SETINA ;## SET UP FOR THE REST
06160 PUSHJ P,ININIT ;## LOOK UP (SECOND FILE IN LIST)
06170 JUMPE A,INERR ;## NOT THERE, ERROR MESSAGE
06180 BOOTOK: MOVEI A,TRUTH(S) ;##(INC T NIL)
06190 SETZ B,
06200 PUSHJ P,INC ;## SELECT
06210 BOOTLP: PUSH P,[.+5] ;** NEW CODE FOR NEW ERRSET
06220 JSP R,ERRST1 ;** SET UP STACK
06230 PUSHJ P,READ
06240 PUSHJ P,EVAL
06250 JRST .-2 ;## A READ-EVAL LOOP. PROTECTED AGAINST
06260 CAIE A,$EOF$(S) ;## ALL ERRS EXCEPT $EOF$ AND ERRORX
06270 JRST BOOTLP ;## LOOP
06280 BOOTOT: PUSHJ P,EXCISE
06290 JRST STRT ;** GO TO TOP LEVEL
06300 PAGE
06310 SUBTTL APR INTERRUPT ROUTINES
06320
06330 ;arithmetic processor interupts
06340 ;mem. protect. violation, nonex. mem. or pdl overflow
06350
06360 APRINT: MOVE R,.JBCNI ;get interrupt bits
06370 TRNE R,MPV+NXM ;what kind
06380 ERR4 @.JBTPC ;an ill mem ref-will become JRST ILLMEM
06390 SKIPN GCFLAG ;** pdl overflow - CHECK IF GCING
06400 JRST MES21 ;** NO
06410 KILLGC: MOVE S,ATMOV ;** JUST IN CASE
06420 STRTIP [SIXBIT /←PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
06430 SETZB F,GCFLAG ;** FORCE A GC FROM TOP-LEVEL
06440 SKIPN CCFLAG
06450 JRST STRT
06460 CCSTRT: MOVEI A,STRT ;** FIRST INTERRUPT IF ↑C HIT
06470 MOVEM A,CCFLAG
06480 JRST CCINT1
06490
06500 MES21: SETZM .JBUUO
06510 SKIPL P ;** (P is usable here - use words between RPDL & SPDL)
06520 STRTIP [SIXBIT /←REG !/]
06530 SKIPL SP
06540 STRTIP [SIXBIT /←SPEC !/]
06550 SKIPE .JBUUO
06560 SPDLOV: ERR3 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
06570 TRNE R,PDOV
06580 SKIPE .JBUUO
06590 HALT ;lisp should not be here
06600 BINER2: SETZM BPSFLG
06610 ERR3 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
06620
06630 COMMENT %
06640 ;** THIS CODE EVIDENTLY BELONGS TO THE "NEW" CONS ROUTINES, AND
06650 ;** SINCE NOBODY ELSE USES IT . . .
06660 ILLMEM: LDB R,[POINT 4,@.JBTPC,XFLD] ;get index field of bad word
06670 CAIE R,F ;does it contain f
06680 ERR3 @.JBTPC ;no! error
06690 PUSHJ P,AGC ;yes! garbage collect
06700 JRST @.JBTPC ;and continue
06710 %
06720 PAGE
06730 SUBTTL UUO HANDLER AND SUBR CALL ROUTINES
06740
06750 UUOMIN==1
06760 UUOMAX==5
06770
06780 REMOTE<
06790 UUOH: X ;jsr location
06800 JRST UUOH2>
06810 UUOH2: MOVEM T,TSV#
06820 MOVEM TT,TTSV#
06830 LDB T,[POINT 9,.JBUUO,OPFLD] ;get opcode
06840 CAIGE T,34 ;is it a function call
06850 JRST ERROR ;or a LISP error
06860 HLRE R,@.JBUUO
06870 AOJN R,UUOS ;jump if arg is not an atom
06880 LDB T,[POINT 4,.JBUUO,ACFLD] ;** (Get type of call)
06890 CAILE T,15
06900 MOVEI R,-15(T) ;** (R=1 (16) or 2 (17) or 0 (SUBR))
06910 HRRZ T,@.JBUUO ;** (T = atom)
06920 UUOH1: HLRZ TT,(T)
06930 HRRZ T,(T)
06940 CAIN TT,SUBR(S)
06950 JRST @UUST(R)
06960 CAIN TT,FSUBR(S)
06970 JRST @UUFST(R)
06980 CAIN TT,LSUBR(S)
06990 JRST @UULT(R)
07000 CAIN TT,EXPR(S)
07010 JRST @UUET(R)
07020 CAIN TT,FEXPR(S)
07030 JRST @UUFET(R)
07040 HRRZ T,(T)
07050 JUMPN T,UUOH1
07060 PUSH P,A ;** (No func. prop.)
07070 PUSH P,B
07080 HRRZ A,.JBUUO
07090 MOVEI B,VALUE(S)
07100 PUSHJ P,GET
07110 JUMPN A,[ HRRZ TT,(A)
07120 POP P,B
07130 POP P,A
07140 JRST UUOEX1]
07150 UUOERR: HRRZ A,.JBUUO
07160 PUSHJ P,EPRINT+2
07170 ERR2 [SIXBIT /UNDEFINED FUNCTION - UUO CALL!/] ;**
07180 SKIPA T,TT
07190 UUOSBR: HLRZ T,(T)
07200 JUMPE T,UUOERR ;** IF FUNC PROP. IS NIL, ERROR
07210 MOVE TT,.JBUUO
07220 HRLI T,(PUSHJ P,)
07230 TLNE TT,1000 ;1000 means no push
07240 TLCA T,34600 ;<PUSHJ P,>xor<JRST>
07250 PUSH P,UUOH
07260 SOS UUOH
07270 HRRZ D,UUOH
07280 CAIG D,SHRST
07290 JRST .+3
07300 SKIPE WRTSTS
07310 JRST .+3
07320 REMOTE<
07330 UUOCL: TLNN TT,2000> ;2000 means no clobber
07340 XCT UUOCL
07350 MOVEM T,@UUOH
07360 MOVE TT,TTSV
07370 EXCH T,TSV
07380 JRST @TSV
07390
07400 UUOS: HRRZ TT,.JBUUO ;** (UUO arg not an atom)
07410 CAILE TT,@GCPP1
07420 CAIL TT,@GCP1
07430 JRST UUOSBR-1
07440 JRST .+2
07450 UUOEXP: HLRZ TT,(T)
07460 UUOEX1: LDB T,[POINT 5,.JBUUO,ACFLD]
07470 TRZN T,20
07480 PUSH P,UUOH
07490 PUSH P,TT
07500 JUMPE T,IAPPLY
07510 CAIN T,17
07520 MOVEI T,1
07530 MOVNS T
07540 HRLZ TT,T
07550 PUSH P,A(TT)
07560 AOBJN TT,.-1
07570 JRST IAPPLY
07580 PAGE
07590 ARGPDL: LDB T,[POINT 4,.JBUUO,ACFLD]
07600 MOVNS T
07610 HRLZ R,T
07620 ARGP1: JUMPE R,(TT)
07630 PUSH P,A(R)
07640 AOBJN R,.-1
07650 JRST (TT)
07660
07670 QTIFY: PUSHJ P,NCONS
07680 MOVEI B,CQUOTE(S)
07690 JRST XCONS
07700
07710 QTLFY: MOVEI A,0
07720 QTLFY1: JUMPE T,(TT)
07730 EXCH A,(P)
07740 PUSHJ P,QTIFY
07750 POP P,B
07760 PUSHJ P,CONS
07770 AOJA T,QTLFY1
07780
07790 PDLARG: MOVEI NACS,1 ;** PUT NIL INTO ARG REGS
07800 BLT NACS,NACS ;**
07810 JRST .+NACS+2(T)
07820 POP P,A+5
07830 POP P,A+4
07840 POP P,A+3
07850 POP P,A+2
07860 POP P,A+1
07870 POP P,A
07880 JRST (TT)
07890
07900 NOUUO: MOVSI B,(TLNN TT,)
07910 SKIPE A
07920 MOVSI B,(TLNA)
07930 HLLM B,UUOCL
07940 EXCH A,NOUUOF#
07950 POPJ P,
07960 PAGE
07970 ;r=0 => compiler calling a SUBR/EXPR
07980 ;r=1 => compiler calling a lsubr
07990 ;r=2 => compiler calling f type
08000
08010 UUST: UUOSBR
08020 UUOS1 ;calling l its a subr
08030 UUOS2 ;calling f
08040
08050 UUFST: UUOS9 ;calling - its a f
08060 UUOS10 ;calling l
08070 UUOSBR
08080
08090 UULT: UUOS7 ;calling - its a l
08100 UUOSBR
08110 UUOS8
08120
08130 UUET: UUOEXP
08140 UUOS5 ;calling l its an expr
08150 UUOS6 ;calling f its an expr
08160
08170 UUFET: UUOS3 ;calling - its a fexpr
08180 UUOS4 ;calling l
08190 UUOEXP
08200
08210 UUOS1: HLRZ R,(T)
08220 MOVE T,TSV
08230 JSP TT,PDLARG
08240 JRST (R)
08250
08260 UUOS3: PUSH P,(T)
08270 JSP TT,ARGPDL
08280 UUOS4A: JSP TT,QTLFY
08290 MOVEI TT,1
08300 DPB TT,[POINT 4,.JBUUO,ACFLD]
08310 UUOS6A: POP P,TT
08320 HLRZS TT
08330 JRST UUOEX1
08340
08350 UUOS4: PUSH P,(T)
08360 MOVE T,TSV
08370 JRST UUOS4A
08380 PAGE
08390 UUOS5: HLRZ R,(T)
08400 MOVE T,TSV
08410 JSP TT,PDLARG
08420 MOVNS T
08430 DPB T,[POINT 4,.JBUUO,ACFLD]
08440 MOVE TT,R
08450 JRST UUOEX1
08460
08470 UUOS6: PUSH P,(T)
08480 PUSH P,UUOH
08490 PUSH P,.JBUUO
08500 JSP TT,ILIST
08510 JSP TT,PDLARG
08520 POP P,.JBUUO
08530 POP P,UUOH
08540 JRST UUOS6A
08550 UUOS8: SKIPA TT,CILIST
08560 UUOS7: MOVEI TT,ARGPDL
08570 HRRM TT,UUOS7A
08580 MOVE TT,.JBUUO
08590 TLNN TT,1000
08600 PUSH P,UUOH
08610 HLRZ TT,(T)
08620 JRST @UUOS7A ;OR ILIST
08630 REMOTE<
08640 UUOS7A: ARGPDL>
08650
08660 UUOS9: PUSH P,T
08670 JSP TT,ARGPDL
08680 UUS10A: JSP TT,QTLFY
08690 MOVSI T,2000
08700 IORM T,.JBUUO
08710 POP P,T
08720 JRST UUOSBR
08730
08740 UUOS10: PUSH P,T
08750 MOVE T,TSV
08760 JRST UUS10A
08770
08780 PAGE
08790 SUBTTL ERROR HANDLER AND BACKTRACE
08800 ;subroutine to print sixbit error message
08810 ERRSUB: MOVSI A,(POINT 6,0)
08820 HRR A,.JBUUO
08830 MOVEM A,ERRPTR#
08840 ERRORB: ILDB A,ERRPTR
08850 CAIN A,01 ;conversion from sixbit
08860 POPJ P,
08870 CAIN A,77
08880 JRST [ PUSHJ P,TERPRI
08890 JRST ERRORB]
08900 ADDI A,40
08910 PUSHJ P,TYO
08920 JRST ERRORB
08930
08940 ;subroutine to return output to previously selected device
08950 OUTRET: SKIPL PRVCNT ;if prvcnt<0 then there was no device deselect
08960 SOSL PRVCNT ;when prvcnt goes negative, then reselect
08970 POPJ P,
08980 PUSH P,PRVSEL# ;previously selected output
08990 POP P,TYOD
09000 POPJ P,
09010
09020 ;subroutine to force error messages out on tty
09030 ERRIO: TALK ;** UNDO ↑O (MOVED FROM BELOW)
09040 MOVE B,ERRSW
09050 CAIE B,INUM0 ;inum0 specifies to print message on selected device
09060 AOSLE PRVCNT ;only if prvcnt already <0 does deselection occur
09070 POPJ P,
09080 MOVE B,[JRST TTYO]
09090 EXCH B,TYOD
09100 MOVEM B,PRVSEL
09110 POPJ P,
09120
09130 REMOTE<
09140 ERRSW: -1> ;0 means no prnt on error
09150 PAGE
09160 ;subroutine to search oblist for closest function to address in r
09170 ERSUB3:
09180 MOVEI A,QST(S)
09190 IFN OLDNIL< HRROI NIL,CNIL2(S)>
09200 IFE OLDNIL< SETZ NIL, >
09210
09220 HRLZ B,INT1
09230 MOVNS B
09240 SETZB AR2A,GOBF
09250 PUSH P,.JBAPR
09260 MOVEI C,[ SETOM GOBF
09270 JRST ERRO2G]
09280 HRRM C,.JBAPR
09290 HRRZ C,VOBLIST(S) ;## GET CURRENT OBLIST
09300 HRRM C,RHX5
09310 HRRM C,RHX2 ;## AND UPDATE LOCATIONS WHICH REF OBLIST
09320 HLRZ C,@RHX5
09330 ERRO2B: JUMPE C,[ AOBJN B,.-1
09340 POP P,.JBAPR ;oblist done, restore
09350 JRST PRINC] ;print closest match
09360 HLRZ TT,(C)
09370 ERRO2C: HRRZ TT,(TT)
09380 JUMPE TT,ERRO2G
09390 HLRZ AR1,(TT)
09400 CAIN AR1,LSUBR(S)
09410 JRST ERRO2H
09420 CAIE AR1,SUBR(S)
09430 CAIN AR1,FSUBR(S)
09440 JRST ERRO2H
09450 HRRZ TT,(TT)
09460 JRST ERRO2C
09470
09480 ERRO2H: HRRZ TT,(TT)
09490 HLRZ TT,(TT)
09500 CAMLE TT,AR2A ;** le to prefer first defn in OBLIST
09510 CAMLE TT,R
09520 JRST ERRO2G
09530 MOVE AR2A,TT
09540 HLRZ A,(C)
09550 ERRO2G: HRRZ C,(C)
09560 JRST ERRO2B
09570 PAGE
09580 ;dispatcher for error message uuos
09590 ERROR: MOVEI A,APRFLG
09600 CALLI A,APRENB ;enable interupts
09610 SETOM ERRTYP# ;** SET FLAG FOR "SERIOUS" ERROR
09620 LDB A,[POINT 9,.JBUUO,OPFLD] ;get opcode
09630 CAIL A,UUOMIN ;what
09640 CAILE A,UUOMAX ;is it?
09650 JRST ILLUUO ;an illegal opcode
09660 JRST @ERRTAB-UUOMIN(A) ;or LISP error
09670 ERRTAB: ERROR1 ;1 ;"correctable" LISP error
09680 ERROR2 ;2 ;"serious" LISP error
09690 ERROR3 ;3 ;space overflow error
09700 ERROR4 ;4 ;ill. mem. ref.
09710 STRTYP ;5 ;print error message and continue
09720
09730 COMMENT % ;** The following causes infinite loop if ERRTN is
09740 ;** too close to top of stack. Use stack slop instead
09750 ERROR3: MOVE P,ERRTN ;IF IN ERRSET, RESTORE P TO THAT LEVEL
09760 SKIPN P
09770 MOVE P,C2 ;else to top level
09780 % ;**
09790 ERROR3: SETOM UUO2# ;$$ AND DON'T ENTER ERRORX
09800 ERROR2: SKIPN ERRSW
09810 JRST ERREND
09820 JRST ERRPRI ;** "SERIOUS" ERRORS ALWAYS PRINT MESSAGE BEFORE BREAKING
09830
09840 ERROR1: SKIPN ERRSW
09850 JRST ERREND ;dont print message, call (err nil)
09860 SETZM ERRTYP ;** CHANGE FLAG TO "CORRECTABLE" ERROR
09870 MOVE A,RSTSW ;** CHECK *RSET FLAG TO CHECK FOR PRINT
09880 CAIN A,ERRORX(S) ;** ERRORX -> NO
09890 JRST ERREND
09900 ERRPRI: PUSHJ P,ERRIO ;print message on tty
09910 PUSHJ P,TERPRI
09920 PUSHJ P,ERRSUB ;print the message
09930 JRST ERRBK ;go the backtrace
09940
09950 STRTYP: PUSHJ P,ERRIO
09960 PUSHJ P,ERRSUB ;print message and continue
09970 PUSHJ P,OUTRET
09980 JRST @UUOH
09990
10000 ;USER ENTRY TO ERROR HANDLER, PRINTS ARG IF NON-NIL
10010 .ERROR: SETOM ERRTYP ;** SET FLAG FOR "SERIOUS" ERROR
10020 JUMPE A,ERREND
10030 SKIPN ERRSW
10040 JRST ERREND
10050 PUSHJ P,ERRIO
10060 PUSH P,[ERRBK] ;** RESTORE I/O WHEN DONE
10070 PUSH P,A ;** SAVE ARG
10080 PUSHJ P,ATOM ;** IS IT AN ATOM?
10090 JUMPE A,.+3 ;** NO
10100 POP P,A ;** YES - GET IT
10110 JRST PRINTC ;** AND GO PRINT IT
10120 POP P,B ;** LIST - PRINT ELEMENTS SEPARATELY
10130 MOVEI A,CPRINTC(S) ;**
10140 JRST .MAPC ;**
10150
10160 ERROR4: HRRZ A,.JBUUO
10170 MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
10180 JRST ERSUB2
10190
10200 ILLUUO: HRRZ A,UUOH
10210 MOVEI B,[SIXBIT / ILL UUO FROM !/]
10220
10230 ERSUB2: SKIPN ERRSW
10240 JRST ERREND ;dont print message
10250 PUSH P,A
10260 PUSH P,B
10270 PUSHJ P,ERRIO
10280 PUSHJ P,TERPRI
10290 PUSHJ P,PRINL2 ;print number
10300 POP P,A
10310 STRTIP (A) ;print message
10320 POP P,R
10330 PUSHJ P,ERSUB3 ;print nearest oblist match
10340 ERRBK:
10350 IFN ALVINE,<
10360 SKIPE BACTRF
10370 PUSHJ P,BKTRC ;print backtrace
10380 >
10390 PUSHJ P,OUTRET ;return to previous device
10400
10410 ERREND: SETZ A, ;## %CLRBFI USED TO BE HERE(FOR ERR NIL)
10420 SKIPN UUO2 ;$$NO ERRORX IF OVERFLOW ERROR
10430 JRST .+3
10440 SETZM UUO2 ;$$RESET TO ZERO
10450 JRST RERX ;$$BOUNCE BACK TO ERRORX
10460 SKIPE RSTSW ;$$NEW *RSET FEATURE
10470 SKIPN ERRSW ;**CHECK ERRSET FLAG
10480 JRST ERR ;$$IF (*RSET NIL) UNBIND AND GO TO TOP LEVEL
10490 PUSHJ P,%CLRBFI ;## CLEAR TTY BUFFER. ELIMINATE FLUSHING
10500 SKIPE A,ERRTYP ;** GET ERROR TYPE FLAG
10510 MOVEI A,TRUTH(S) ;** NZ = SERIOUS, Z = CORRECTABLE
10520 PUSHJ P,NCONS ;** SET TO PASS FLAG TO ERRORX
10530 MOVEI B,ERRORX(S) ;$$SET TO CALL ERROR HANDLER
10540 PUSHJ P,XCONS ;$$CREATE FORM (ERRORX flag)
10550 JRST EVAL ;$$AND EVALUATE IT
10560 PAGE
10570 ERR: SETZM INHERR ;CLEAR RERX FLAG JUST IN CASE
10580 CAIN A,ERRORX(S) ;$$BOUNCE TO ERRORX IF A=ERRORX
10590 JRST RERX
10600 ERR2: SKIPN ERRTN
10610 JRST STRT ;not in an errset, or bad error -- go to top level
10620 MOVE P,ERRTN
10630 ERR1: POP P,B
10640 PUSHJ P,UBD ;unbind to previous errset
10650 POP P,ERRSW
10660 POP P,ERRTN
10670 SKIPN INHERR#
10680 JRST ERRP4 ;and proceed
10690
10700 RERX: SETZM INHERR ;$$ POP TO A BREAK ERRSET
10710 MOVE B,ERRSW
10720 CAIE B,ERRORX(S)
10730 SETOM INHERR
10740 JRST ERR2
10750
10760 ERRSET: MOVE B,A ;** New ERRSET with entry points for
10770 HRRZ A,(B) ;** in-line compiled ERRSET code
10780 CAIN A,0
10790 SKIPA A,[1] ;** (USE T (1) FOR ERR FLAG IF MISSING)
10800 HLRZ A,(A)
10810 JSP R,ERRST1
10820 HLRZ A,(B) ;** GET EXPRESSION AND EVALUATE IT
10830 PUSHJ P,EVAL
10840 JRST ERRST2 ;** NO ERROR, SO GO UNDO STACK
10850
10860 ERRST1: PUSH P,PA3 ;** SET UP STACK FOR ERROR TRAP
10870 PUSH P,PA4 ;** (CALLED FROM COMPILED CODE)
10880 PUSH P,ERRTN ;** NOTE THAT THE COMPILER HAS FAITH IN THE
10890 PUSH P,ERRSW ;** FACT THAT 5 ITEMS ARE PUSHED - DON'T
10900 PUSH P,SP ;** DISAPPOINT HIM
10910 MOVEM P,ERRTN
10920 MOVEM A,ERRSW
10930 JRST (R)
10940
10950 ERRST2: PUSHJ P,NCONS ;** COME HERE FOR NON-ERROR RETURN
10960 ;** (CALLED FROM COMPILED CODE)
10970 SETZM INHERR ;CLEAR RERX FLAG
10980 JRST ERR1
10990
11000 SYSCLR: SETZM BSFLG ;FUNCTION TO MAKE SYSTEM LOOK NEW
11010 SETZM CONSVA ;## RESET CONS COUNT
11020 SETZM GCTIM ;## RESET GC TIME
11030 JRST EXCISE ;## EXCISE
11040 PAGE
11050 ;error messages
11060
11070
11080 RMERR: MOVE A,T ;$$ BAD READ MACRO, GET THE NAME
11090 PUSHJ P,EPRINT+2 ;$$
11100 ERR2 [SIXBIT /UNDEFINED READ MACRO!/]
11110
11120 BNDERR: PUSHJ P,EPRINT+2 ;$$ATTEMPT TO REBIND NIL OR T (** OR ILLEGAL VAR)
11130 ERR2 [SIXBIT /CAN'T BE USED AS VARIABLE!/]
11140
11150 RPAERR: PUSHJ P,EPRINT+2 ;$$PRINT OUT OFFENDING ITEM
11160 ERR2 [SIXBIT /IS AN ATOM, CAN'T BE RPLACA'D!/]
11170
11180 RPDERR: PUSHJ P,EPRINT+2 ;$$
11190 ERR2 [SIXBIT /CAN'T BE RPLACD'D (NIL OR INUM)!/]
11200
11210 DOTERR: ERR2 [SIXBIT /DOT CONTEXT ERROR!/]
11220 UNDFUN: HLRZ A,(AR1)
11230 PUSHJ P,EPRINT
11240 ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
11250 UNBVAR: PUSHJ P,EPRINT
11260 ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
11270 NONNUM: ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
11280 NOPNAM: MOVE A,C ;** GET OFFENDER
11290 PUSHJ P,EPRINT+2
11300 ERR2 [SIXBIT /HAS NO PRINT NAME!/]
11310 ;NOLIST: ERR2 [SIXBIT /NO LIST - MAKNAM!/] ;**
11320 TOMANY: ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
11330 ;TOOFEW: ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/] ;**
11340 UNDTAC: HRRZ A,(C)
11350 UNDTAG: PUSHJ P,EPRINT
11360 ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
11370 EG1: PUSHJ P,EPRINT
11380 ERR1 [SIXBIT /UNDEFINED PROG TAG - GO!/]
11390 EG2: PUSHJ P,EPRINT+2
11400 ERR2 [SIXBIT /GO WITH NO PROG!/]
11410 EG3: ERR2 [SIXBIT /RETURN WITH NO PROG!/]
11420 ARRERR: ERR2 [SIXBIT /ARRAY SUBSCRIPT OUT OF BOUNDS!/] ;**
11430 PUTERR: MOVE A,B ;** GET THE BAD ARG
11440 PUSHJ P,EPRINT+2 ;**
11450 ERR2 [SIXBIT /NOT AN ATOMIC SYMBOL - PUTPROP!/] ;**
11460 NAPERR: ERR2 [SIXBIT /NON-NULL TAIL - NCONC OR APPEND!/] ;**
11470 MAPERR: ERR2 [SIXBIT /NON-NULL TAIL - MAP!/] ;**
11480 PAGE
11490 IFE ALVINE,<XLIST> ;** Old ALVINE backtrace routine
11500 IFN ALVINE,<
11510
11520 ;backtrace subroutine
11530 BKTRC: MOVEI D,-1(P)
11540 MOVN A,BACTRF
11550 ADDI A,INUM0
11560 JUMPL A,[ ADD A,P ;backtrace specific number
11570 JRST .+3]
11580 SKIPN A,ERRTN ;backtrace to previous errset
11590 MOVE A,C2 ;or top level
11600 HRRZM A,BAKLEV#
11610 STRTIP [SIXBIT /←BACKTRACE←!/]
11620 BKTR2: CAMG D,BAKLEV
11630 JRST FALSE ;done
11640 HRRZ A,(D) ;get pdl element
11650 CAIGE A,FS(S)
11660 JUMPN A,.+2 ;this is (hopefully) a true program address
11670 SOJA D,BKTR2 ;not a program address, continue
11680 CAIN A,ILIST3
11690 JRST BKTR1A ;argument evaluation
11700 BKTR1B: CAIN A,CPOPJ
11710 JRST [ HLRZ A,(D) ;calling a function
11720 PUSHJ P,PRINC
11730 XCT "-",CTY
11740 STRTIP [SIXBIT /ENTER !/]
11750 SOJA D,BKTR2]
11760 HLRZ B,-1(A)
11770 CAILE B,(JCALLF 17,@(17))
11780 CAIN B,(PUSHJ P,) ;tests for various types of calls
11790 CAIGE B,(FCALL)
11800 SOJA D,BKTR2 ;not a proper function call
11810 PUSH P,-1(A) ;save object of function call
11820 MOVEI R,-1(A) ;location of function call
11830 PUSHJ P,ERSUB3 ;print closest oblist match
11840 MOVEI A,"-"
11850 PUSHJ P,TYO
11860 POP P,R
11870 TLNE R,17
11880 HRRZ R,ERSUB3 ;qst -- cant handle indexed calls
11890 HRRZS R
11900 HLRO B,(R)
11910 AOSN B
11920 JRST [ HRRZ A,R ;was calling an atomic function
11930 PUSHJ P,PRINC ;print its name
11940 JRST .+2]
11950 PUSHJ P,ERSUB3 ;was calling a code location -- print closest match
11960 MOVEI A," "
11970 PUSHJ P,TYO
11980 BKTR1: SOJA D,BKTR2 ;continue
11990
12000 BKTR1A: HRRZ B,-1(D)
12010 CAIE B,EXP2
12020 CAIN B,ESB1
12030 JRST .+2
12040 JRST BKTR1B ;hum, not really evaluating arguments
12050 HLRE B,-1(D)
12060 ADD B,D
12070 HLRZ A,-3(B)
12080 JUMPE A,BKTR1
12090 PUSHJ P,PRINC
12100 XCT "-",CTY
12110 STRTIP [SIXBIT /EVALARGS !/]
12120 JRST BKTR1
12130 ;** TURNED OFF UNLESS ALVINING
12140 BAKGAG: EXCH A,BACTRF#
12150 POPJ P,
12160 >
12170 IFE ALVINE,<LIST>
12180 PAGE
12190 SUBTTL TYI AND TYO
12200 ;input
12210 ITYI: PUSHJ P,TYI ;## RETURN ASCII VALUE OF INPUT CH
12220 FIXI: ADDI A,INUM0
12230 POPJ P,
12240
12250 TYI: MOVEI AR1,1 ;## TO TEST FOR LINED TYPESEQUENCE #, ETC
12260 PUSHJ P,TYIA
12270 JUMPE A,.-1
12280 LDB B,RATFLD ;** Check if start of comment (now goes thru
12290 CAIE B,COMCHR ;** read table in case several comment chars)
12300 POPJ P,
12310 PUSHJ P,COMENT
12320 JRST TYI+1
12330
12340 TYIA: SKIPE A,OLDCH ;## IF CH IN OLDCH
12350 JRST TYI1 ;## TAKE CARE OF IT
12360 TYID: XCT TYI2 ;## INPUT A CHARACTER
12370 REMOTE<
12380 TYI2: JRST TTYI> ;sosg x for other device input
12390 ;other device input
12400 JRST TYI2X
12410 TYI3B: ILDB A,@TYI3# ;pointer
12420 XCT TYI3A ;## SEE IF LINED TYPE WORD
12430 REMOTE<
12440 TYI3A: TDNN AR1,@X> ;pointer
12450 POPJ P, ;## NO, OK
12460
12470 IFN STPGAP,<
12480 MOVE A,@TYI3A
12490 CAMN A,[<ASCII / />+1] ;page mark for stopgap
12500 AOSA PGNUM ;increment page number
12510 MOVEM A,LINUM
12520 >
12530 MOVNI A,5
12540 ADDM A,@TYI2 ;adjust character count for line number
12550 AOS @TYI3 ;increment byte pointer over line number and tab
12560 JRST TYID
12570
12580 REMOTE<
12590 TYI2X: INPUT X,
12600 TYI2Y: STATZ X,740000
12610 ERR2 AIN.8 ;input error
12620 IFN RANDOM,<
12630 TYI2W: AOS X> ;[UT] INCREMENT BUFFER COUNT
12640 TYI2Z: STATO X,20000
12650 JRST TYI3B ;continue with file
12660 TYIEOF: JRST TYI2Q ;END OF FILE
12670 >
12680 TYI2Q: PUSH P,T
12690 PUSH P,C
12700 PUSH P,R ;** (PUSH/POP AR1 removed)
12710 MOVE A,INCH
12720 HRRZ C,CHTAB(A) ;get location of data for this channel
12730 HLRZ T,CHTAB(A) ;inlst -- remaining files to input
12740 JUMPE T,TYI2E ;none left -- stop
12750 PUSHJ P,SETIN ;start next input
12760 PUSHJ P,ININIT ;## INIT THE FILE
12770 JUMPE A,INERR ;## CAN'T FIND FILE, ERROR
12780 POP P,R
12790 POP P,C
12800 POP P,T
12810 JRST TYI
12820
12830 TYI2E: PUSHJ P,INCNT ;(inc nil t)
12840 ;** TALK Removed to allow output from several files to be killed with one ↑O
12850 MOVEI A,$EOF$(S) ;we are done
12860 JRST ERR
12870
12880 IFN STPGAP,<
12890 PGLINE: MOVE C,[POINT 7,LINUM]
12900 PUSHJ P,NUM10 ;convert ascii line number to a integer
12910 ADDI A,INUM0
12920 MOVE B,PGNUM
12930 ADDI B,INUM0+1
12940 JRST XCONS>
12950
12960 REMOTE<
12970 OLDCH: 0
12980 IFN STPGAP,<
12990 PGNUM: 0
13000 LINUM: 0
13010 0>> ;zero to terminate num10
13020 PAGE
13030 ;TTYECHO - COMPLEMENTS THE TTY: ECHO BIT AND RETURNS T IF THE ECHO
13040 ; IS BEING TURNED ON AND NIL IF IT IS BEING TURNED OFF
13050 ; - TAKES NO ARGUMENTS
13060 ECHO: SETO A,
13070 GETLCH A ;GET STATUS BITS
13080 TLC A,4 ;COMPLEMENT THE ECHO BIT
13090 SETLCH A ;RESTORE THE BITS
13100 TLNE A,4 ;TEST TO GET FINAL VALUE
13110 JRST FALSE
13120 JRST TRUE
13130
13140 ;CLRBFI - CLEARS TTY INPUT BUFFER FOR USER ERRORS
13150 ; - 0 ARGS AND RETURNS NIL
13160 %CLRBFI:CLRBFI ;CLEAR BUFFER
13170 SETZM SMAC ;CLEAR SPLICE LIST
13180 SETZM OLDCH ;CLEAR LAST CHAR.
13190 JRST FALSE
13200 PAGE
13210 ;teletype input
13220
13230 TTYI: SKIPE DDTIFG ;## DDT MODE?
13240 JRST TTYID
13250 SKPINC ;** this gets rid of redundant prompts
13260 JRST DOPROM ;** when line is almost full
13270 TTYINC: INCHWL A ;**
13280
13290 TTYXIT: CAMN A,ERRCHR ;## BELL, NEED NOT BE ↑G
13300 JRST TTYERC
13310 SKIPN PSAV ;** CHECK FOR SPECIAL CNTRL CHARS ONLY IN READ
13320 POPJ P,
13330 CAMN A,RERCHR
13340 JRST REREAD ;** RESTART READ
13350 CAME A,EDCHR
13360 POPJ P,
13370 SETOM EDFLAG# ;** SET FLAG FOR EDIT
13380 JRST TTYI ;** AND IGNORE CHAR
13390
13400 DOPROM: SKIPE TLKFLG# ;** DO WE NEED A TALK? (FIRST PROMPT)
13410 TALK
13420 SETZM TLKFLG ;** NO TALK ON SUBSEQUENT PROMPTS
13430 SETOM CHRFLG ;** CHCT IS NOW BAD & SHOULD BE RECOMPUTED
13440 OUTCHR PROMCH ;** GIVE HIM THE PROMPT CHAR
13450 JRST TTYINC
13460
13470 TTYERC:
13480 IFN ALVINE,<
13490 SKIPE PSAV1# ;bell from alvine?
13500 JRST [ MOVE P,PSAV1 ;yes, return to alvine
13510 JRST @ED1];$$DOUBLY IMPROVED MAGIC>
13520 MOVEI A,ERRORX(S) ;** RETURN ERRORX AS THE VALUE
13530 JRST RERX ;$$ RETURN TO AN ERRORX ERRSET
13540
13550 TTYID: INCHRW A ;single character input ddt submode style
13560 SETOM CHRFLG ;** CHCT IS NOW BAD & SHOULD BE RECOMPUTED
13570 CAIE A,RUBOUT
13580 JRST TTYXIT
13590 OUTCHR ["\"] ;echo backslash
13600 DORUB: SKIPE PSAV
13610 JRST REREAD ;rubout in read resets to top level of read
13620 POPJ P,
13630
13640 ERRCH: MOVEI A,-INUM0(A) ;## CHANGE BELL CHARACTER
13650 EXCH A,ERRCHR ;## RETURN OLD CHARACTER
13660 JRST FIX1A ;## CONVERT IT
13670
13680 EDITCH: MOVEI A,-INUM0(A) ;** CHANGE EDIT CHARACTER
13690 EXCH A,EDCHR
13700 JRST FIX1A
13710
13720 RERDCH: MOVEI A,-INUM0(A) ;** CHANGE REREAD CHARACTER
13730 EXCH A,RERCHR
13740 JRST FIX1A
13750
13760 REMOTE <
13770 ERRCHR: BELL
13780 EDCHR: CNTLF
13790 RERCHR: CNTLZ
13800 PROMCH: "*"
13810 LSPRMP: "*"+INUM0>
13820
13830 PROMPT: SKIPN A
13840 SKIPA A,PROMCH
13850 MOVEI A,-INUM0(A) ;$$CHANGE FROM INUM
13860 EXCH A,PROMCH ;$$CHANGE PROMPT CHARACTER AND RETURN OLD ONE
13870 MOVEI A,INUM0(A) ;$$CHANGE TO INUM
13880 POPJ P, ;$$
13890
13900 INTPRP: SKIPN A
13910 SKIPA A,LSPRMP
13920 EXCH A,LSPRMP ;$$ EXCHANGE FOR OLD TOP LEVEL PROMPT
13930 POPJ P, ;$$
13940
13950 READP: SKPINC ;$$ T IFF A CHARACTER HAS BEEN TYPED
13960 JRST FALSE ;$$ (DOES NOT CHECK OLDCH)
13970 JRST TRUE
13980
13990 UNTYI: MOVEI B,-INUM0(A) ;$$ UN-READ A CHARACTER (PUT IT IN OLDCH)
14000 MOVEM B,OLDCH
14010 POPJ P, ;$$ RETURN ARG AS VALUE
14020
14030 DDTIN: EXCH A,DDTIFG#
14040 POPJ P,
14050 PAGE
14060 ;output
14070 ITYO: PUSH P,A ;**
14080 PUSHJ P,CHRCT ;** MAKE SURE CHCT IS CORRECT
14090 POP P,A ;**
14100 SUBI A,INUM0
14110 PUSHJ P,TYO
14120 JRST FIXI
14130
14140 TYO: CAIG A,CR
14150 JRST TYO3
14160 SOSGE CHCT
14170 JRST TYO1
14180 JRST TYOD
14190 REMOTE<
14200 TYOD: JRST TTYO+X ;sosg x for other device
14210 ;other device output
14220 JRST TYO2V ;[UT] CH. FROM TYO2X
14230 TYO5: IDPB A,X
14240 POPJ P,
14250
14260 TYO2V:
14270 IFN RANDOM,<
14280 TYO2W: AOS X> ;[UT] INCREMENT BUFFER COUNT
14290 TYO2X: OUT X,
14300 JRST TYO5
14310 ERR2 [SIXBIT /OUTPUT ERROR!/]>
14320
14330 TYO1: PUSH P,A ;linelength exceeded
14340 MOVE A,IGSTRT ;ignored cr-lf (** Ch. from IGCRLF)
14350 SKIPE OUTCH ;** IGCRLF not needed if TTY (Fix from CMU)
14360 PUSHJ P,TYOD
14370 PUSHJ P,TERPRI ;force out a cr-lf, with special mark
14380 SKIPN OUTCH ;** IGEND not needed if TTY
14390 JRST .+4 ;**
14400 MOVE A,IGEND ;** PUT OUT IGEND IF NOT LF (FIX FROM YALE)
14410 CAIE A,LF ;**
14420 PUSHJ P,TYOD ;**
14430 POP P,A
14440 SOSA CHCT
14450 TYO4: POP P,B
14460 JRST TYOD
14470
14480 TYO3: CAIGE A,TAB
14490 JUMPN A,TYO+2 ;everything between 0(null) and 11(tab) decrement chct
14500 PUSH P,B
14510 MOVE B,LINL
14520 CAIN A,TAB
14530 JRST [ SUB B,CHCT
14540 IORI B,7 ;simulate tab effect on chct
14550 SUB B,LINL
14560 SETCAM B,CHCT
14570 JRST TYO4]
14580 CAIN A,CR
14590 MOVEM B,CHCT ;reset chct after a cr
14600 JRST TYO4
14610 PAGE
14620 LINELENGTH:
14630 JUMPE A,LINEL1
14640 SUBI A,INUM0
14650 HRRZ B,LINL ;** GET OLD LINELENGTH
14660 HRRM A,LINL
14670 SUB A,B ;** GET HOW MUCH LINELENGTH IS CHANGING
14680 ADDM A,CHCT ;** AND UPDATE CHCT
14690 LINEL1: HRRZ A,LINL
14700 JRST FIXI
14710
14720 CHRCT: SKIPN OUTCH ;** If TTY not selected . . .
14730 SKIPN CHRFLG ;** or no chars have been input on line . . .
14740 JRST CHRCT1 ;** then just return CHCT
14750 MOVEI A,.TOHPS ;** Otherwise, compute new CHCT
14760 MOVEM A,TRMTAB
14770 MOVE A,[XWD 2,TRMTAB]
14780 CALLI A,TRMOP. ;** Reads position of carriage
14790 JRST CHRCT1 ;** Error - forget it
14800 SUB A,LINL ;** Convert to # of positions left
14810 MOVNM A,CHCT
14820 SETZM CHRFLG ;** Needn't recompute til next read
14830 CHRCT1: MOVE A,CHCT
14840 JRST FIXI
14850
14860 CHRPOS: PUSHJ P,CHRCT ;** Compute CHRPOS = LINELENGTH - CHRCT + 1
14870 MOVE A,LINL
14880 SUB A,CHCT
14890 AOJA A,FIXI
14900
14910 REMOTE<
14920 LINL: TTYLL
14930 CHCT: TTYLL>
14940 PAGE
14950 ;teletype output
14960 TTYO: OUTCHR A ;output single character in a
14970 SETOM TLKFLG# ;** Set that TALK needed before next prompt
14980 CAIN A,CR
14990 SETZM CHRFLG# ;** CHRCT is now correct
15000 POPJ P,
15010
15020 TTYRET: PUSHJ P,OUTCNT
15030 JRST INCNT
15040
15050 ;** NEW ROUTINE TO TURN OFF CNTRL-O - ELIMINATES PROBLEM WHEREBY ↑O
15060 ;** WAS STRUCK AFTER ERROR MESSAGE, ETC., WAS ALREADY PRINTED
15070 ;** (I.E., WHILE LAST BUFFER WAS BEING DUMPED) SO TALK COULDN'T UNDO IT.
15080 ;** WE NOW WAIT FOR ALL OUTPUT TO BE FLUSHED BEFORE TURNING OFF ↑O
15090 TTYCLR: SETZ A, ;USER ENTRY POINT (RETURNS NIL)
15100 PUSH P,A ;SYSTEM ENTRY POINT (SAVES A)
15110 MOVEI A,.TOSOP
15120 MOVEM A,TRMTAB ;SET TO CHECK OUPUT BUFFER
15130 TTYCL1: MOVE A,[XWD 2,TRMTAB]
15140 CALLI A,TRMOP. ;CHECK IF OUTPUT BUFFER EMPTIED
15150 JRST TTYCL2 ;YES - CAN NOW TURN OFF ↑O
15160 MOVEI A,144 ;NO - WAIT 100 MSEC. MAIN EFFECT IS TO GIVE
15170 CALLI A,HIBER ;UP CONTROL OF MACHINE WHILE BUFFER IS FLUSHED
15180 JRST TTYCL2 ;ERROR - FORGET IT
15190 JRST TTYCL1 ;CHECK IT AGAIN
15200 TTYCL2: SKPINL ;THIS CLEARS ↑O BIT
15210 JFCL
15220 JRST POPAJ
15230 REMOTE<
15240 TRMTAB: X ;(.TOSOP or .TOHPS)
15250 200000+X> ;(UDX)
15260
15270 REMOTE<
15280 TTOCH: 0
15290 IFN STPGAP,<
15300 0 ;tty page number always zero
15310 0 ;tty line number -- always zero
15320 >
15330 TTOLL: TTYLL
15340 TTOHP: TTYLL>
15350 PAGE
15360 SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL
15370 ;convert ascii to sixbit for device initialization routines
15380 SIXMAK: SETZM SIXMK2#
15390 MOVE AR1,[POINT 6,SIXMK2]
15400 HRROI R,SIXMK1
15410 PUSHJ P,PRINTA ;use print to unpack ascii characters
15420 MOVE A,SIXMK2
15430 POPJ P,
15440
15450 SIXMK1: ADDI A,40
15460 TLNN AR1,770000
15470 POPJ P, ;last character position -- ignore remaining chars
15480 CAIN A,"."+40
15490 MOVEI A,0 ;ignore dots at end of numbers for decimal base
15500 CAIN A,":"+40
15510 HRLI AR1,(POINT 6,0,29) ;deposit : in last char position
15520 IDPB A,AR1
15530 POPJ P,
15540
15550 ;subroutine to process next item in file name list
15560 INXTIO: ;JUMPE T,NXTIO ;** (not necessary)
15570 HRRZ T,(T)
15580 NXTIO: HLRZ A,(T)
15590 PUSHJ P,ATOM
15600 JUMPE A,CPOPJ ;non-atomic
15610 HLRZ A,(T)
15620 JRST SIXMAK ;make sixbit if atomic
15630
15640 ;right normalize sixbit
15650 LSH A,-6
15660 SIXRT: TRNN A,77
15670 JRST .-2
15680 POPJ P,
15690 PAGE
15700
15710 ;## SUBROUTINE TO TEST FOR A DEVICE OR QUEUE. USED BY I/O ROUTINES
15720 ;## AND THE QUEUE ROUTINES. LEAVES A=0 IF NOT ATOM AND B=0 IF NOT
15730 ;## DEVICE OR QUEUE.
15740
15750 DEVCHK: PUSHJ P,NXTIO ;## MAKE SIXBIT IF AN ATOM
15760 LDB B,[POINT 6,A,35];## GET LAST CHAR
15770 CAIN B,':' ;## DEVICE?
15780 TRZA A,77 ;## YES, CLEAR CHAR BUT LEAVE B INTACT
15790 SETZ B, ;## NO, CLEAR B
15800 POPJ P, ;## DONE, IF A=0 OR B=0, NOT A DEVICE
15810
15820 ;## SUBROUTINE TO PARSE THE I/O SPECIFICATION. DEFAULT IS DSK IF
15830 ;## NO DEVICE SPECIFIED.
15840 IOSUB: MOVEM T,DEVDAT# ;## SAVE ARG FOR ERRORS
15850 SKIPE DEV ;## DEVICE ALREADY SPECIFIED?
15860 JRST IOSUB1 ;## YES, FORGET DEFAULT
15870 SETZM PPN ;## CLEAR PPN
15880 IFN SFDFLG,< SETZM PPN+1> ;[UT] CLEAR A SFD LOCATION
15890 MOVSI A,'DSK' ;## STORE DSK AS DEFAULT
15900 MOVEM A,DEV
15910 IOSUB1: PUSHJ P,DEVCHK ;## SEE IF DEVICE SPECIFIED
15920 JUMPE A,IOPPN+1 ;## NON-ATOMIC ARG, MUST BE PPN OR (FILE.EXT)
15930 JUMPE B,IOFIL3 ;## NOT A DEVICE, MUST BE FILE NAME
15940 PUSH P,A ;** Device: save SIXBIT
15950 HLRZ A,0(T) ;** Get orig. atom
15960 MOVEI B,CDEVPPN(S) ;** And check to see if
15970 PUSHJ P,GET ;** it has a DEVPPN property
15980 JUMPE A,.+3 ;** No - real device
15990 POP P,B ;** Yes - pop stack
16000 JRST IOPPN1 ;** And use ppn found
16010 POP P,A ;** Get SIXBIT back
16020 SETZM PPN
16030 IFN SFDFLG,< SETZM PPN+1> ;[UT] CLEAR A SFD LOCATION
16040 IODEV2: MOVEM A,DEV
16050 IODEV3: PUSHJ P,INXTIO
16060 IOPPN: JUMPN A,IOFIL2 ;not ppn or (fil.ext)
16070 PUSHJ P,PPNEXT
16080 JUMPN A,IOEXT ;(fil.ext)
16090 HLRZ A,(T)
16100 IOPPN1: PUSHJ P,CNVPPN ;## CONVERT PPN
16110 IFE SFDFLG,< MOVEM A,PPN> ;[UT] SAVE PPN
16120 JRST IODEV3 ;%% DON'T ZAP DEVICE NAME FOR PPN
16130
16140 IOEXT: HLRZ A,(T) ;(file.ext)
16150 HRRZ A,(A) ;get cdr == extension
16160 PUSHJ P,SIXMAK
16170 HLLM A,EXT
16180 HLRZ A,(T)
16190 HLRZ A,(A) ;get car = file name
16200 PUSHJ P,SIXMAK
16210 FIL: PUSH P,A
16220 PUSHJ P,INXTIO
16230 JRST POPAJ
16240
16250 IOFIL2: CAIN B,":"-40
16260 POPJ P, ;saw a :,not file name
16270 IOFIL3: SETZM EXT ;file name -- clear extension
16280 JRST FIL
16290
16300 PPNEXT: JUMPE T,CPOPJ ;end of file name list
16310 HLRZ A,(T)
16320 HRRZ A,(A) ;cdar
16330 JRST ATOM ;ppn iff (not(atom(cdar l)))
16340
16350 CHNSUB: MOVE T,A
16360 HLRZ A,(T)
16370 PUSHJ P,ATOM
16380 JUMPE A,TRUE ;non-atomic head of list -- no channel named
16390 HLRZ A,(T)
16400 PUSHJ P,SIXMAK
16410 ANDI A,77
16420 CAIN A,":"-40
16430 JRST TRUE ;device name, assume channel name t
16440 HLRZ A,(T) ;channel name -- return it
16450 HRRZ T,(T)
16460 POPJ P,
16470 ;## LEFT HALF OF A CHANNEL TABLE ENTRY IS THE REMAINING
16480 ;## FILE LIST. RH POINTS TO EXTENDED HEADER.
16490
16500 REMOTE<
16510 CHTAB=.-FSTCH
16520 BLOCK NIOCH>
16530
16540 PAGE
16550 ;search for channel name in chtab
16560 TABSR1: MOVE A,[XWD -NIOCH,FSTCH]
16570 MOVE C,CHTAB(A)
16580 CAME B,CHNAM(C)
16590 AOBJN A,.-2
16600 CAMN B,CHNAM(C)
16610 POPJ P, ;found it!!!
16620 JRST FALSE ;lost
16630
16640 ;search for channel name in chtab, and if not there find a free channel, and
16650 ;if no free channel, allocate a new buffer and channel
16660 TABSRC: MOVE B,A
16670 PUSHJ P,TABSR1
16680 JUMPN A,DEVCLR ;found the channel
16690 PUSH P,B
16700 MOVE B,0
16710 PUSHJ P,TABSR1 ;find a physical channel no. for a free channel
16720 JUMPE A,[ERR2 [SIXBIT $NO I/O CHANNELS LEFT !$]]
16730 POP P,B
16740 JUMPN C,DEVCLR ;found free channel which had buffer space previously
16750 PUSH P,A ;must allocate new buffer
16760 MOVEI A,BLKSIZ
16770 SETZ D, ;SPECIAL RELOCATION - SEE LOAD
16780 PUSHJ P,MORCOR ;expand core for buffer if necessary
16790 MOVE C,A
16800 POP P,A
16810 HRRM C,CHTAB(A)
16820 DEVCLR: HRRZ C,CHTAB(A)
16830 MOVEM B,CHNAM(C) ;[UT] (LH) = I/O BIT, (RH) = NAME
16840 HRRZM A,CHANNEL#
16850 POPJ P,
16860
16870 ;subroutine to reset all i/o channe -- used by excise and realloc
16880 IOBRST: HRRZ A,.JBREL
16890 HRLM A,.JBSA
16900 MOVEM A,CORUSE#
16910 MOVEM A,.JBSYM
16920 SETZM LDFLG# ;** Indicate that symbols are gone
16930 SETZM CHTAB+FSTCH
16940 MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
16950 BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
16955 CALLI RESET ;** Kill any open channels
16960 POPJ P,
16970 PAGE
16980 INPUT1: PUSHJ P,CHNSUB ;determine channel name
16990 MOVEI AR1,(A) ;## SAVE CH NAME
17000 EXCH AR1,(P) ;## EXHANGE WITH RETURN ADDR
17010 PUSH P,AR1 ;## AND STUFF THE RETURN ADDR. IN
17020 INPUT2: PUSHJ P,TABSRC ;## GET PHYSICAL CHANNEL NUMBER
17030 MOVEM A,CHANNEL ;## SAVE IT
17040 SETZM DEV ;## CLEAR DEV SO THAT WE CAN
17050 ;## DEFAULT IF APPROPRIATE
17060 JRST SETIN1 ;## SET UP FOR INITIALIZTION
17070
17080 INPUT: PUSHJ P,INPUT1
17090 PUSHJ P,ININIT
17100 INFAIL: JUMPE A,INERR ;## CAN'T FIND FILE
17110 JRST POPAJ
17120
17130 COMMENT % ;** If you want it, you got it
17140 BINPUT: PUSHJ P,INPUT1 ;## IMAGE BINARY INPUT
17150 PUSHJ P,BNINIT
17160 JRST INFAIL
17170 %
17180 ISFILE: JUMPE A,.+5 ;## ROUTINE TO TELL USER IF A FILE EXISTS
17190 PUSH P,A ;## SAVE A IF NON-NIL
17200 MOVEI A,(B) ;## GET THE FILE NAME
17210 PUSHJ P,NCONS ;## (FILNAM)
17220 POP P,B ;## GET THE DEVICE BACK
17230 PUSHJ P,XCONS ;## (DEV FILNAM) OR (FILNAM) WHEN HERE
17240 PUSH P,A ;## SAVE IT FOR RETURN
17250 PUSHJ P,RENSUB ;## SEE IF IT'S THERE
17260 PUSH P,A ;## SAVE THE ANSWER
17270 PUSHJ P,RENCLR ;## CLEAR THE CHANNEL
17280 POP P,A ;## ANSWER IN A
17290 JUMPN A,POPAJ ;## IF NON-NIL, THEN IT'S THERE
17300 POP P,B ;## POP ANSWER OFF
17310 POPJ P, ;## AND RETURN NIL
17320
17330 RENSUB: MOVEM A,DEVDAT ;## SAVE IT FOR ERROR MSGS
17340 PUSHJ P,GENSYM ;## DON'T CLOBBER CURRENT CHANNELS
17350 MOVE T,DEVDAT ;## GET IT BACK
17360 PUSHJ P,INPUT2 ;## SET UP AND OPEN
17370 JRST ININIT ;## AND INIT
17380
17390 RENAME: PUSHJ P,RENSUB ;## RENAME SETUP
17400 JUMPE A,RENCLR ;## NIL IF CAN'T FIND FILE
17410 LDB A,[POINT 9,LOOKIN+2,8] ;** GET PROTECTION
17420 MOVEM A,OLDPRO# ;** AND SAVE IT
17430 IFN SFDFLG,< ;[UT] GET OLD FILE'S PATH SO YOU CAN RENAME PROPERLY
17440 MOVE A,CHANNEL ;[UT] CHANNEL NUMBER
17450 HRRZM A,SFDBLK ;[UT] THIS ARG TO PATH WILL GET CHANNEL'S PATH
17460 MOVE A,[XWD SFDLEN+4,SFDBLK]
17470 CALLI A,PATH. ;[UT] GO DO IT
17480 JRST RENCLR ;[UT] FAILED???
17490 MOVE A,CHANNEL ;[UT] PUT PATH INTO CHANNEL PATH
17500 HRRZ C,CHTAB(A)
17510 MOVE A,[XWD PPN,CHPPN] ;[UT] SET UP BLT TO MOVE IT
17520 ADDI A,(C) ;[UT] INDEX
17530 BLT A,CHPPN+SFDLEN(C) ;[UT] TRANSFER PATH
17540 >
17550 PUSHJ P,SETINA ;## PROCESS THE NEW NAME
17560 XCT RNAME ;## EXECUTE
17570 JRST RENCLR ;## RETURN NIL IF FAILURE
17580 PUSHJ P,RENCLR ;## CLEAR CHANNEL
17590 MOVE A,OLDPRO ;** GET PROTECTION
17600 JRST FIXI ;** AND RETURN IT
17610
17620 REMOTE <
17630 RNAME: RENAME X,LOOKIN ;## RENAME FILE
17640 >
17650 DELERR: PUSHJ P,AIOP
17660 PUSHJ P,RENCLR ;## KILL THE CHANNEL
17670 ERR2 [SIXBIT /CAN'T DELETE FILE!/]
17680
17690 DELETE: PUSHJ P,RENSUB ;## FIRST SETUP(ALLOWS DEFAULT TO DSK:)
17700 JRST .+2 ;## ALREADY INIT'ED
17710 DELET1: PUSHJ P,ININIT ;## INIT AND LOOKUP
17720 JUMPE A,DELET2 ;## IF FILE NOT THERE, IGNORE
17730 SETZM LOOKIN ;## BLAST FILE NAME
17740 SETZM EXT ;## AND EXTENSION
17750 XCT RNAME ;## AND RENAME OUT OF EXISTENCE
17760 JRST DELERR ;## RENAME FAILURE
17770 DELET2: JUMPE T,RENCLR ;## DONE
17780 MOVEM T,DEVDAT ;## SAVE REST OF LIST FOR MSGS.
17790 PUSHJ P,SETINA ;## PROCESS NEXT FILE
17800 JRST DELET1 ;## AND DO IT AGAIN
17810
17820 RENCLR: PUSH P,CHANNEL ;## CLEAR CHANNEL
17830 SETO B, ;## FAKE (INC RENCHANNEL T)
17840 PUSHJ P,IOSEL ;## RELEASE THE CHANNEL
17850 JRST POPAJ ;## RETURN NIL (IOSEL CHANGED THINGS)
17860
17870
17880 ;## TO LOOK UP A UFD FOR DIRECTORY FNS. SUBR
17890
17900 UFDINP: PUSH P,A
17910 MOVEI T,(B)
17920 PUSHJ P,TABSRC
17930 MOVEM A,CHANNEL ;## HAVE A CHANNEL
17940 MOVE A,[XWD 'DSK','UFD']
17950 HRLZM A,EXT
17960 HLLZM A,DEV
17970 IFE SFDFLG,< ;[UT]
17980 MOVE B,[XWD 1,1] ;## UFD'S SHOULD BE ON [1,1]
17990 MOVEM B,PPN>
18000 SKIPN A,T
18010 JRST NILPPN ;** NIL: USE MYPPN
18020 PUSHJ P,ATOM ;** IS IT AN ATOM?
18030 EXCH A,T ;**
18040 JUMPE T,NILPPN+1 ;** NO: MUST BE PPN, SO USE IT
18050 MOVEM A,DEVDAT ;**
18060 MOVEI B,CDEVPPN(S) ;** CHECK TO SEE IF IT HAS
18070 PUSHJ P,GET ;** A DEVPPN PROPERTY
18080 JUMPN A,NILPPN+1 ;** YES - USE IT AS PPN
18090 MOVE A,DEVDAT ;** NO - MUST BE ERSATZ DEVICE
18100 PUSHJ P,SIXMAK ;** CONVERT IT
18110 TRZ A,77 ;** CLEAR OUT THE :
18120 CALLI A,DEVPPN ;** GET THE ASSOCIATED PPN
18130 JRST AUFD.1 ;** BAD DEVICE
18140 PUSHJ P,MYPPN+2 ;** GOT IT - CONVERT TO PPN FORM
18150 JRST NILPPN+1 ;** AND USE IT
18160 NILPPN:
18170 IFE SFDFLG,<PUSHJ P,MYPPN> ;## IF B=NIL, DEFAULT TO USER'S PPN
18180 IFN SFDFLG,<PUSHJ P,PATH> ;[UT] IF B=NIL, DEFAULT TO USER'S PATH
18190 MOVEM A,DEVDAT
18200 PUSHJ P,CNVPPN ;## CONVERT PPN
18210 SETZ T, ;## ZAP T (NO MORE FILES)
18220 IFN SFDFLG,<
18230 JUMPE C,NOSFD ;[UT] IF NO SFD'S
18240 MOVEI B,'SFD' ;[UT] ELSE EXT IS .SFD
18250 HRLZM B,EXT
18260 SETZ A, ;[UT] LAST SFD SHOULD BE 0
18270 EXCH A,PPN(C) ;[UT] A IS FILE(SFD) NAME
18280 JRST FDLU
18290 NOSFD: MOVE A,[XWD 1,1] ;[UT] UFD'S ON 1,1
18300 EXCH A,PPN
18310 FDLU:>
18320 PUSHJ P,SETIN2 ;## SETUP
18330 PUSHJ P,BNINIT ;## INIT AS BINARY
18340 JUMPE A,AUFD.1 ;** ERROR IF NOT THERE
18350 PUSHJ P,ININBF ;## SET UP BUFFERS
18360 JRST POPAJ ;## RETURN CHANNEL
18370
18380 MYPPN: GETPPN A, ;## GET PPN
18390 CAI ;## WIERD SKIP RETURN ON THIS UUO
18400 HLRZ C,A ;## ASSUME PPN'S ARE INUMS
18410 HRRZI A,INUM0(A) ;## CONVERT
18420 PUSHJ P,NCONS
18430 HRRZI B,INUM0(C)
18440 JRST XCONS ;## (PROJ PRGRM)
18450
18460 CNVPPN: MOVS A,(A) ;## ASSUME PPNS INUMS
18470 HRRI A,-INUM0(A) ;## LH=CDR, RH=CAR
18480 IFE SFDFLG,< ;[UT]
18490 MOVSS A ;## SWAP HALVES
18500 HLR A,(A) ;## RH=CADR NOW
18510 HRRI A,-INUM0(A)
18520 POPJ P,>
18530
18540 IFN SFDFLG,<
18550 HRLZM A,PPN ;[UT] SAVE PROJ# IN PPN
18560 MOVSS A ;[UT] SWAP HALVES AGAIN
18570 MOVS A,(A) ;[UT] AND AGAIN (CDR)
18580 HRRI A,-INUM0(A) ;[UT] PROG#
18590 HRRM A,PPN ;[UT] SAVE PROG# IN PPN
18600 HLRZS A ;[UT] A IS NOW CDDR
18610 MOVNI C,SFDLEN ;[UT] COUNT OF SFDS
18620 PUSH P,A ;[UT] RESERVE SOME ROOM
18630 NXTSFD: JUMPE A,ENDSFD ;[UT] DONE WITH SFDS
18640 MOVS A,(A) ;[UT] GET CDR,,CAR
18650 HLRZM A,(P) ;[UT] SAVE CDR
18660 HRLM C,(P) ;[UT] AND INDEX
18670 MOVEI A,(A) ;[UT] ONLY WANT CAR
18680 PUSHJ P,SIXMAK ;[UT] MAKE IT SIXBIT
18690 HLRE C,(P) ;[UT] RETRIEVE INDEX
18700 MOVEM A,PPN+1+SFDLEN(C);[UT] SAVE THIS SFD
18710 HRRZ A,(P) ;[UT] RESTORE A
18720 AOJL C,NXTSFD ;[UT] INCREMENT AND GO GET MORE
18730 ENDSFD: SETZM PPN+1+SFDLEN(C) ;[UT] GUARANTEE A 0 SFD
18740 ADDI C,SFDLEN ;[UT] SFD COUNT
18750 MOVEI B,SFDBLK
18760 MOVEM B,LPPN ;[UT] MAKE SURE IT POINTS TO PATH BLOCK
18770 JRST POPBJ> ;[UT] RETURN NIL, CLEAR STACK
18780 PAGE
18790 ;[UT] SOME STUFF FOR PATHS
18800 IFN SFDFLG,<
18810 PATH: ;FSUBR- RETURN PRESENT PATH IF ARG=NIL
18820 ; ELSE IF ONE ARG THEN RETURN PATH OF THAT CHANNEL
18830 ; ELSE SET PATH TO ARG
18840 ; RETURNS PRESENT PATH UNLESS YOU COULDN'T SET PATH IN WHICH
18850 ; CASE IT RETURNS NIL
18860 JUMPE A,GETPTH
18870 HRRZ B,(A) ;[UT] CHECK FOR ONE ARG
18880 JUMPE B,CHNPTH ;[UT] ONE ARG, PRESUME A CHANNEL
18890 PUSH P,A ;[UT] SAVE ARG
18900 PUSHJ P,CNVPPN ;[UT] FILL LOOK UP BLOCK IN
18910 HRRZI A,-2 ;[UT] 0,,-2 SETS PATH
18920 PUSHJ P,PATH1 ;[UT] GO DO IT
18930 JUMPE A,POPBJ ;[UT] IF NIL, THEN IGNORE POP AND RETURN
18940 JRST POPAJ ;[UT] ELSE RETURN ARGUMENT
18950
18960 PATH1: SETZM SFDBLK+1 ;[UT] USE ALREADY EXISTING SCAN SWITCH
18970 PATH2: MOVEM A,SFDBLK ;[UT] LOAD PATH ARGUMENT
18980 MOVE B,[XWD SFDLEN+4,SFDBLK] ;[UT] AC FOR PATH
18990 CALLI B,PATH. ;[UT] GO DO IT
19000 JRST FALSE ;[UT] PATH UUO FAILED, RETURN NIL
19010 JRST TRUE ;[UT] ALL IS COOL
19020
19030 GETPTH: HRRZI A,-1 ;[UT] 0,,-1 GETS THE PATH
19040 PUSHJ P,PATH1 ;[UT] GO GET PATH
19050 JUMPE A,CPOPJ ;[UT] HUH?
19060 ; THIS RETURNS A PATH THAT IS IN PPN.... AS (PROJ# PROG# SFD1 ...)
19070 GTPTH3: PUSH P,[NIL] ;[UT] END OF VALUE LIST
19080 MOVEI B,SFDLEN ;[UT] COME FROM BOTTOM UP
19090 GTPTH2: MOVE A,PPN(B) ;[UT] GET SFD
19100 JUMPE A,GTPTH1 ;[UT] A 0 SFD
19110 PUSH P,B ;[UT] SAVE INCREMENT
19120 PUSHJ P,SIXATM ;[UT] MAKE AN ATOM
19130 POP P,B ;[UT] RETRIEVE INDEX
19140 EXCH B,(P) ;[UT] GET VALUE LIST, SAVE INDEX
19150 PUSHJ P,CONS ;[UT] CONS ON NEW ONE
19160 EXCH A,(P) ;[UT] SAVE VALUE, GET INDEX
19170 SKIPA B,A ;[UT] MOVE INDEX TO B AND SKIP
19180 GTPTH1: SETZM (P) ;[UT] MAKE SURE VALUE LIST IS NIL IF NO SFD
19190 SOJG B,GTPTH2 ;[UT] ARE WE DONE?
19200 HRRZ A,PPN ;[UT] YES, NOW WORK ON PROG. NUM
19210 MOVEI A,INUM0(A) ;[UT] MAKE INTO AN INUM
19220 POP P,B ;[UT] GET SFD LIST
19230 PUSHJ P,CONS ;[UT] CONS ON PROG NUM
19240 MOVE B,A ;[UT]
19250 HLRZ A,PPN ;[UT] NOW GET PROJ NUM
19260 MOVEI A,INUM0(A) ;[UT] MAKE INUM
19270 JRST CONS ;[UT] CONS IT ON AND RETURN
19280 PAGE
19290 ; RETURNS (DEV: (PATH) (FILE.EXT)(FILE2.EXT)...)
19300 ; FOR CHANNEL IT IS CALLED WITH
19310 ; FOR TTY IT RETURNS (TTY:)
19320
19330 CHNPTH: HLRZ B,(A) ;[UT] GET ARG
19340 JUMPE B,PTHTTY ;[UT] CHECK FOR TTY: CASE
19350 PUSHJ P,TABSR1 ;[UT] GET PHYSICAL CHANNEL #
19360 JUMPN A,CHNPT1 ;[UT] FOUND IT AS INPUT
19370 TLO B,400000 ;[UT] LOOK FOR IT AS OUTPUT
19380 PUSHJ P,TABSR1 ;[UT]
19390 JUMPE A,CPOPJ ;[UT] ERROR. RETURN NIL
19400 CHNPT1: HRRZM A,SFDBLK ;[UT] ARGUMENT FOR PATH.
19410 HRRZ C,CHTAB(A) ;[UT] POINTER TO DATA
19420 PUSH P,C ;[UT] SAVE IT
19430 MOVE A,CHFILE(C) ;[UT] NAME OF FILE (** ch from DMOVE)
19440 PUSHJ P,SIXATM ;[UT] MAKE AN ATOM
19450 PUSH P,A ;[UT] AND SAVE (** ch from EXCH)
19455 MOVE C,-1(P) ;[UT] GET POINTER (** new)
19460 MOVE A,CHEXT(C) ;[UT] GET EXTENSION (** new)
19470 JUMPE A,.+5 ;[UT] CHECK IF NONE
19480 PUSHJ P,SIXATM ;[UT] MAKE ATOM
19490 MOVE B,(P) ;[UT] GET FILE
19500 PUSHJ P,XCONS ;[UT] MAKE (FILE . EXT)
19510 MOVEM A,(P) ;[UT] SAVE IT
19520 MOVE A,[XWD SFDLEN+4,SFDBLK] ;[UT] ARG FOR PATH.
19530 CALLI A,PATH. ;[UT] GO GET CHANNEL PATH.
19540 ERR2 [SIXBIT /CAN'T GET PATH!/]
19550 PUSHJ P,GTPTH3 ;[UT] MAKE INTO PATH EXPRESSION
19560 EXCH A,(P) ;[UT] SAVE IT
19570 PUSHJ P,NCONS ;[UT] MAKE ((FILE . EXT))
19580 POP P,B ;[UT] GET PATH AGAIN
19590 PUSHJ P,XCONS ;[UT] MAKE ((PATH) (FILE.EXT))
19600 EXCH A,(P) ;[UT] SAVE AND GET CHANNEL DATA
19610 MOVE A,CHDEV(A) ;[UT] GET DEVICE
19620 PUSHJ P,SIXCAT ;[UT] MAKE ATOM
19630 POP P,B ;[UT] GET REST
19640 JRST CONS ;[UT] RETURN (DEV (PATH)(FILE.EXT))
19650 PTHTTY: MOVSI A,'TTY' ;[UT] NIL CHANNEL NAME = TTY
19660 PUSHJ P,SIXCAT ;[UT] GET NAME
19670 JRST NCONS ;[UT] MAKE LIST
19680
19690 SCAN: ; TURNS OFF SCAN SWITCH IF ARG IS NIL, ELSE TURNS IT ON
19700 ; RETURNS NIL OR NON-NIL ACCORDING TO WHAT IT WAS BEFORE
19710 PUSH P,A ;[UT] SAVE ARG
19720 HRRZI A,-1 ;[UT] WANT DEFAULT PATH
19730 PUSHJ P,PATH1
19740 MOVEI A,2 ;[UT] BIT 34 INDICATES /SCAN
19750 TDZN A,SFDBLK+1 ;[UT] IF SCAN IS ON, SETS A TO NIL AND SKIPS
19760 MOVEI A,TRUTH(S) ;[UT] HERE T IS NO SCAN, NIL IS SCAN
19770 CAMN A,(P) ;[UT] SEE IF SAME AS ASKED FOR
19780 JRST STSCAN ;[UT] SAME, THUS MUST SET AS PER REQUEST
19790 SKIPE (P) ;[UT] NOPE, BUT MAYBE NON-NIL VERSUS T
19800 JUMPN A,STSCAN ;[UT] NEITHER NIL, MUST SET SCAN
19810 JRST POPAJ ;[UT] WANTED WHAT IT WAS ALREADY,GIVE BAK ARG
19820 STSCAN: MOVEI A,3 ;[UT] SET SCAN SWITCHES
19830 ANDCMM A,SFDBLK+1 ;[UT] FLIP BITS 34,35, ZERO 0-33
19840 HRRZI A,-2 ;[UT] 0,,-2 SETS PATH (AND SCAN)
19850 PUSHJ P,PATH2 ;[UT] GO SET IT
19860 POP P,A ;[UT] RETURN NOT ARGUMENT
19870 JRST NOT>
19880 PAGE
19890 SETINA: MOVE A,CHANNEL ;## FOR ROUTINES THAT PROCESS MORE
19900 HRRZ C,CHTAB(A) ;## AND KEEP THE CHANNEL IN CHANNEL
19910
19920 SETIN: MOVEM A,CHANNEL
19930 MOVE A,CHDEV(C)
19940 MOVEM A,DEV
19950 IFE SFDFLG,<
19960 MOVE A,CHPPN(C)
19970 MOVEM A,PPN>
19980 IFN SFDFLG,<
19990 MOVE A,[XWD PPN,CHPPN] ;[UT] SET CHANNEL PATH
20000 ADDI A,(C) ;[UT] INDEX
20010 MOVSS A ;[UT] PUT IN RIGHT ORDER
20020 BLT A,PPN+SFDLEN ;[UT] TRANSFER PATH
20030 MOVEI A,SFDBLK ;[UT] RESET LPPN
20040 MOVEM A,LPPN
20050 SETZM SFDBLK+1> ;[UT] USE DEFAULT SCAN
20060 SETIN1: PUSHJ P,IOSUB ;get device and file name
20070 SETIN2: MOVEM A,LOOKIN ;file name
20080 MOVE A,DEV
20090 MOVEM A,BDEV ;## ALLOW IMAGE BINARY MODE
20100 CALLI A,DEVCHR
20110 TLNN A,INB
20120 JRST AIN.2 ;not input device
20130 TLNN A,AVLB
20140 JRST AIN.4 ;not available
20150 MOVE A,CHANNEL
20160 DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers
20170 DPB A,[POINT 4,BNINIT,ACFLD] ;## FOR IMAGE BINARY
20180 DPB A,[POINT 4,RNAME,ACFLD] ;## FOR RENAME
20190 DPB A,[POINT 4,INLOOK,ACFLD]
20200 DPB A,[POINT 4,ININBF,ACFLD]
20210 HLLZS EXT ;%% CLEAR RIGHT HALF
20220 SETZM LOOKIN+2 ;%% CLEAR THIRD WORD
20230 HRRZ B,CHTAB(A)
20240 HRLM T,CHTAB(A) ;save remaining file name list
20250 MOVE A,DEV ;[UT] SAVE CHANNEL DEVICE
20260 MOVEM A,CHDEV(B)
20270 MOVE A,LOOKIN ;[UT] FILE NAME
20280 MOVEM A,CHFILE(B) ;[UT] SAVE IT
20290 MOVE A,EXT ;[UT] EXTENSION
20300 MOVEM A,CHEXT(B) ;[UT] SAVE IT
20310 IFE SFDFLG,<
20320 MOVE A,PPN ;[UT] SAVE CHANNEL PPN
20330 MOVEM A,CHPPN(B)>
20340 IFN SFDFLG,<
20350 MOVE A,[XWD PPN,CHPPN] ;[UT] SAVE CHANNEL PATH
20360 ADDI A,(B) ;[UT] INDEX
20370 BLT A,CHPPN+SFDLEN(B)> ;[UT] SAVE WHOLE PATH
20380 IFN RANDOM,< SETZM CHBUFS(B)> ;[UT] ZERO BUFFER COUNT
20390 MOVEI A,CHDAT(B)
20400 MOVEM A,DEV1 ;pointer to bufdat
20410 MOVEM A,BDEV1 ;## IMAGE BINARY MODE
20420 POPJ P, ;## SET UP FOR INITIALIZTION
20430 REMOTE<
20440
20450 BNINIT: INIT X,13 ;## INIT DEVICE IN IMAGE BINARY
20460 BDEV: X
20470 BDEV1: X
20480 JRST AIN.4 ;## CAN'T INIT (** ch from AIN.7)
20490 JRST INITOK
20500 ININIT: INIT X,
20510 DEV: X
20520 DEV1: X
20530 JRST AIN.4 ;cant init (** ch from AIN.7)
20540 INITOK:
20550 ; PUSH B,DEV ;[UT] ALREADY DID THIS (SET CHDEV)
20560 ; PUSH B,PPN ;[UT] ALREADY DID THIS (SET CHPPN)
20570 ;[UT] A TEMPORARY PATCH UNTIL MONITOR GETS FIXED
20580 ; IT WON'T LOOK UP PROPERLY IF SFD BLOCK IS ALL 0'S
20590 SKIPN PPN ;[UT] SFD BLOCK IS NOT ALL 0'S
20600 SETZM LPPN ;[UT] MAKE MONITOR KNOW YOU WANT DEFAULT
20610 INLOOK: LOOKUP X,LOOKIN
20620 JRST FALSE ;## LET SOMEONE ELSE HANDLE THE ERROR
20630 JRST IRET1>
20640
20650 IRET1: ADDI B,CHOCH-1 ;[UT] POINT TO OLDCH
20660 ;** (Code to reset LPPN removed - will be done elsewhere)
20670 PUSH B,[0] ;oldch
20680
20690 IFN STPGAP,<
20700 PUSH B,[0] ;page number
20710 PUSH B,[0] ;line number
20720 ADDI B,COUNT+1-CHLINE ;[UT] SET B TO POINT TO FIRST LOC AFTER COUNT
20730 >
20740
20750 IFE STPGAP,<ADDI B,COUNT+1-CHOCH> ;[UT]
20760 HRRM B,.JBFF
20770 JRST ININBF
20780
20790 REMOTE<
20800 ININBF: INBUF X,NIOB
20810 JRST TRUE ;## RETURN FROM GOOD LOOKUP WITH T
20820
20830
20840 ENTR:
20850 IFE SFDFLG,<
20860 LOOKIN: BLOCK 4
20870 EXT=LOOKIN+1
20880
20890 PPN=LOOKIN+3>
20900 IFN SFDFLG,<
20910 LOOKIN: Z
20920 EXT: Z
20930 Z
20940 LPPN: SFDBLK ;[UT] EXTENDED LOOKUP
20950 SFDBLK: 0,,-1 ;[UT] PATH BLOCK
20960 Z ;[UT] WORD FOR SCAN SWITCHES
20970 PPN: Z
20980 BLOCK SFDLEN
20990 Z> ;[UT] GUARANTEE ZERO
21000 >
21010 PAGE
21020 OUTPUT: PUSHJ P,CHNSUB ;get channel name
21030 PUSH P,A
21040 TLO A,400000 ;[UT] set bit for output IN LH
21050 ;[UT] RH WON'T DO IF LOW SEG>400000
21060 PUSHJ P,TABSRC ;get physical channel number
21070 SETZM DEV ;## CLEAR DEV FOR DEFAULT TO DSK:
21080 PUSHJ P,IOSUB ;get device and file name
21090 MOVEM A,ENTR ;file name
21100 HLLZS ENTR+1 ;%% CLEAR RIGHT HALF
21110 HRRZ A,VFLPRO(S) ;** Get desired protection
21120 CAIG A,INUMIN ;** If not an INUM use 0
21130 SKIPA A,0 ;** Gives default protection code
21140 SUBI A,INUM0 ;**
21150 LSH A,↑D27 ;** Shift it into protection field
21160 MOVEM A,ENTR+2 ;** Stick it in with zero date
21170 MOVE A,CHANNEL
21180 DPB A,[POINT 4,AOUT2,ACFLD] ;setup channel numbers
21190 DPB A,[POINT 4,OUTENT,ACFLD]
21200 DPB A,[POINT 4,OUTOBF,ACFLD]
21210 HRRZ B,CHTAB(A)
21220 IFN RANDOM,<SETZM CHBUFS(B)> ;[UT] ZERO BUFFER COUNT
21230 MOVE A,ENTR ;[UT] FILE NAME
21240 MOVEM A,CHFILE(B) ;[UT] SAVE IT
21250 MOVE A,ENTR+1 ;[UT] EXTENSION
21260 MOVEM A,CHEXT(B) ;[UT] SAVE IT
21270 MOVEI A,CHDAT(B)
21280 HRLM A,AOUT3+1
21290 MOVE A,DEV
21300 MOVEM A,AOUT3
21310 CALLI A,DEVCHR
21320 TLNN A,OUTB
21330 JRST AOUT.2 ;not output device
21340 TLNN A,AVLB
21350 JRST AOUT.4 ;not available
21360 JRST AOUT2
21370 REMOTE<
21380 AOUT2: INIT X,
21390 AOUT3: X
21400 X
21410 JRST AOUT.4 ;cant init
21420 IFN CHDEV-CHNAM-1,<ADDI B,CHDEV-CHNAM-1> ;[UT] IF CHDEV.NE.CHNAM+1
21430 PUSH B,DEV
21440 ;[UT] PATCH TO BYPASS MONITOR BUG WHEN LOOKING UP WITH PATH BLOCK
21450 ; THAT IS ALL ZEROES
21460 SKIPN PPN ; SKIP IF NOT ALL ZEROES
21470 SETZM LPPN ; MAKE IT DEFAULT PATH
21480 OUTENT: ENTER X,ENTR
21490 JRST OUTERR ;cant enter
21500 JRST ORET1>
21510 ORET1: ADDI B,CHLL-CHDEV-1 ;[UT] ALIGN FOR NEXT PUSH
21520 PUSH B,[LPTLL] ;linelength
21530 PUSH B,[LPTLL] ;chrct
21540 ADDI B,COUNT+1-CHHP ;[UT] POINT TO JUST AFTER COUNT
21550 HRRM B,.JBFF
21560 XCT OUTOBF
21570 REMOTE<
21580 OUTOBF: OUTBUF X,NIOB
21590 >
21600 JRST POPAJ
21610 PAGE
21620 INCNT: MOVEI A,NIL ;(INC NIL T)
21630 MOVEI B,TRUTH(S)
21640
21650 INC: PUSH P,INCH#
21660 PUSHJ P,IOSEL
21670 JUMPE C,.+3 ;** Can't release TTY
21680 JUMPN B,INC2 ;released channel
21690 SKIPA
21700 MOVEI C,TTOCH-CHOCH ;tty deselect
21710 IFN STPGAP,<
21720 MOVEI B,CHOCH(C)
21730 HRLI B,OLDCH
21740 BLT B,CHLINE(C) ;save channel data
21750 >
21760 IFE STPGAP,<
21770 MOVE B,OLDCH
21780 MOVEM B,CHOCH(C)
21790 >
21800 JRST INC2+1
21810 INC2: SETZM INCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
21820 JUMPE A,ITTYRE ;select tty
21830 MOVE B,A
21840 PUSHJ P,TABSR1 ;determine physical channel number
21850 JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
21860 HRRZM A,INCH
21870 DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
21880 DPB A,[POINT 4,TYI2Y,ACFLD]
21890 DPB A,[POINT 4,TYI2Z,ACFLD]
21900 HRRZ A,CHTAB(A)
21910 MOVEI T,COUNT(A)
21920 HRLI T,(SOSG)
21930 MOVEI B,POINTR(A)
21940 HRRM B,TYI3 ;set up tyi parameters
21950 HRRM B,TYI3A
21960 IFN RANDOM,<
21970 MOVEI B,CHBUFS(A) ;[UT] SET TO INCREMENT BUFFER COUNT
21980 HRRM B,TYI2W>
21990 INC3:
22000 IFN STPGAP,<
22010 MOVSI B,CHOCH(A)
22020 HRRI B,OLDCH
22030 BLT B,LINUM ;restore channel data
22040 >
22050 IFE STPGAP,<
22060 MOVE B,CHOCH(A)
22070 MOVEM B,OLDCH
22080 >
22090 MOVEM T,TYI2
22100 IOEND: POP P,A
22110 JUMPE A,CPOPJ
22120 MOVE A,CHTAB(A) ;get channel name
22130 HRRZ A,(A)
22140 ; TRZ A,400000 ;clear output bit [UT]
22150 POPJ P,
22160
22170 ITTYRE: SETZM INCH
22180 MOVE T,[JRST TTYI] ;reselect tty
22190 MOVEI A,TTOCH-CHOCH
22200 JRST INC3
22210 ;** RETURN CURRENT INPUT CHANNEL
22220 GETICH: MOVE A,INCH
22230 JRST IOEND+1
22240
22250 IOSEL: MOVE C,-1(P)
22260 JUMPE C,CPOPJ ;tty
22270 JUMPE B,IOSELZ ;dont release
22280 IOSEL1: DPB C,[POINT 4,RLS,ACFLD]
22290 XCT RLS
22300 REMOTE<
22310 RLS: RELEASE X, ;release channel
22320 >
22330 HRRZS CHTAB(C) ;release channel table entry
22340 MOVEM 0,@CHTAB(C) ;blast channel name
22350 SETZM -1(P)
22360 IOSELZ: HRRZ C,CHTAB(C)
22370 POPJ P,
22380 PAGE
22390 OUTCNT: MOVEI A,NIL ;(OUTC NIL T)
22400 MOVEI B,TRUTH(S)
22410
22420 OUTC: PUSH P,OUTCH#
22430 PUSHJ P,IOSEL
22440 JUMPE C,.+3 ;** Can't release TTY
22450 JUMPN B,OUTC2 ;closed this file
22460 SKIPA
22470 MOVEI C,TTOLL-CHLL ;tty deselect
22480 MOVE B,CHCT
22490 MOVEM B,CHHP(C) ;save channel data
22500 MOVE B,LINL
22510 MOVEM B,CHLL(C)
22520 JRST OUTC2+1
22530 OUTC2: SETZM OUTCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
22540 JUMPE A,OTTYRE ;return to tty
22550 TLO A,400000 ;[UT] set output bit
22560 MOVE B,A
22570 PUSHJ P,TABSR1 ;determine physical channel number
22580 JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
22590 DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
22600 HRRZM A,OUTCH
22610 HRRZ A,CHTAB(A)
22620 MOVEI B,POINTR(A)
22630 HRRM B,TYO5 ;set up tyo2 parameters
22640 MOVEI T,COUNT(A)
22650 HRLI T,(SOSG)
22660 IFN RANDOM,<
22670 MOVEI B,CHBUFS(A) ;[UT] SET TO INCREMENT BUFFER LOADS
22680 HRRM B,TYO2W>
22690 OUTC3: MOVE B,CHLL(A)
22700 MOVEM B,LINL
22710 MOVE B,CHHP(A)
22720 MOVEM B,CHCT
22730 MOVEM T,TYOD
22740 JRST IOEND
22750
22760 OTTYRE: SETZM OUTCH
22770 MOVE T,[JRST TTYO]
22780 MOVEI A,TTOLL-CHLL ;tty reselect
22790 JRST OUTC3
22800 ;** RETURN CURRENT OUTPUT CHANNEL
22810 GETOCH: MOVE A,OUTCH
22820 JRST IOEND+1
22830 PAGE
22840 AOUT.2:
22850 AIN.2: PUSHJ P,AIOP
22860 ERR2 [SIXBIT /ILLEGAL DEVICE!/]
22870
22880 AOUT.4:
22890 AIN.4: PUSHJ P,AIOP
22900 ERR2 [SIXBIT /DEVICE NOT AVAILABLE!/]
22910
22920 INERR: PUSHJ P,AIOP ;**
22930 LDB A,[POINT 3,LOOKIN+1,35] ;**
22940 CAIE A,2 ;**
22950 AIN.7: ERR1 [SIXBIT /CAN'T FIND FILE!/]
22960 ERR2 [SIXBIT /FILE IS READ PROTECTED!/]
22970
22980 OUTERR: PUSHJ P,AIOP ;**
22990 LDB A,[POINT 3,ENTR+1,35] ;**
23000 CAIN A,2 ;**
23010 ERR2 [SIXBIT /FILE IS WRITE PROTECTED!/]
23020 CAIN A,3 ;**
23030 ERR2 [SIXBIT /FILE IS IN USE!/]
23040 ERR1 [SIXBIT /CAN'T WRITE FILE!/]
23050
23060 AIN.8: SIXBIT /INPUT ERROR!/
23070 AUFD.1: PUSHJ P,AIOP ;**
23080 ERR2 [SIXBIT /CAN'T READ DIRECTORY!/]
23090
23100 AIOP: MOVE A,DEVDAT
23110 JRST EPRINT
23120
23130 PAGE
23140 ; RANDOM I/O FUNCTIONS
23150
23160 IFN RANDOM,<
23170 ; GTOPOS GETS THE POSITION OF THE CHARACTER ABOUT TO BE OUTPUT.
23180 ; GTIPOS GETS THE POSITION OF THE CHARACTER ABOUT TO BE INPUT.
23190 ; THEY RETURN A NUMBER CORRESPONDING TO THE BYTE POSITION OF THE
23200 ; CHARACTER IN THE FILE.
23210 ; SETPOS SETS THE POSITION OF THE INPUT CHANNEL TO INPUT THE
23220 ; CHARACTER IN THE BYTE POSITION INDICATED BY IT'S ARG.
23230 GTOPOS: SKIPA A,OUTCH ;[UT] GET POSITION ON OUTPUT CHANNEL
23240 GTIPOS: MOVE A,INCH ;[UT] GET POSITION OF INPUT CHANNEL
23250 JUMPE A,CPOPJ ;[UT] EXIT IF TTY:
23260 HRRZ A,CHTAB(A)
23270 MOVE B,CHBUFS(A) ;[UT] # OF BUFLOADS
23280 SUBI B,1
23290 IMULI B,BFCHRS ;[UT] GET TO CHARACTERS
23300 PUSH P,B ;[UT] SAVE FOR A WHILE
23310 SKIPGE B,CHDAT(A) ;[UT] GET THE POSITION OF HEAD OF BUFFER
23320 JRST NODAT ;[UT] BUT LOOK OUT FOR UNLOADED BUFFER
23330 PUSHJ P,GTCPOS ;[UT] GET BYTE POSITION IN BUFFER
23340 NODAT1: POP P,A ;[UT] GET CHARS IN PREVIOUS BUFFERS
23350 ADD A,C ;[UT] COMPUTE TOTAL CHARS.
23360 JRST FIX1A ;** Ch. from MAKNUM
23370 NODAT: SETZB C,0(P) ;[UT] CLEAR ALL IF NO BUFFER LOADED
23380 JRST NODAT1 ;[UT] AND CLEAN UP (RETURN 0)
23390
23400 SETPOS: PUSH P,A ;[UT] SAVE ARGUMENT
23410 PUSHJ P,NUMVAL ;[UT] GET NUMERIC VALUE OF ARG
23420 MOVE B,A
23430 MOVE A,INCH ;[UT] DO IT ON INPUT CHANNEL
23440 JUMPE A,POPBJ ;[UT] RETURN NIL IF ON TTY:
23450 HRRZ A,CHTAB(A)
23460 SETZM CHOCH(A) ;[UT] CLEAR OUT OLD CHAR.
23470 IDIVI B,BFCHRS ;[UT] GO BACK TO BUFFERLOADS.
23480 PUSH P,C ;[UT] SAVE EXCESS BYTES
23490 ADDI B,1 ;[UT] FIRST BUFFER IS 1
23500 CAMN B,CHBUFS(A) ;[UT] CHECK TO SEE IF AT RIGHT BUFFER
23510 SKIPGE C,CHDAT(A) ;[UT] WATCH OUT FOR EMPTY BUFFER
23520 JRST STUPOS ;[UT] GO DO USETI
23530 MOVE B,C ;[UT] FOR GTCPOS
23540 PUSHJ P,GTCPOS ;[UT] GET CHANNEL BYTE POSITION
23550 MOVE A,INCH ;[UT] CHANNEL NUMBER
23560 MOVE A,CHTAB(A) ;[UT] CHANNEL INFO
23570 ADDM C,COUNT(A) ;[UT] UNDO BACK TO BEGINNING OF BUFFER
23580 MOVE B,CHDAT(A) ;[UT] POINTER TO BUF.HEADER
23590 ADDI B,1 ;[UT] POINT TO WORD BEFORE BUF. STORAGE
23600 HRLI B,00700 ;[UT] POINT TO ZEROTH BIT POSITION
23610 MOVEM B,POINTR(A) ;[UT] POINT BEFORE ALL DATA
23620
23630 USETIR: MOVE B,COUNT(A) ;[UT] PICK UP NUMBER OF CHARS READ
23640 POP P,C ;[UT] RETRIEVE CHARS IN THIS BUFFER
23650 SUB B,C ;[UT] KNOCK OFF THIS NUMBER
23660 ADDI B,1 ;[UT] ALIGN IT RIGHT
23670 MOVEM B,COUNT(A) ;[UT] AND RESTORE IT
23680 MOVE B,C
23690 IDIVI B,5 ;[UT] COMPUTE WORDS, CHARS
23700 ;[UT] PRESUME POINTER POINTS TO START OF BUFFER -1
23710 ADDI B,1
23720 ADDM B,POINTR(A) ;[UT] POINT TO RIGHT WORD
23730 IMULI C,7
23740 MOVNS C
23750 ADDI C,44 ;[UT] GET TO RIGHT POSITION
23760 DPB C,[POINT 6,POINTR(A),5] ;[UT] DEPOSIT IN POINTER
23770 JRST POPAJ ;[UT] RETURN ARGUMENT
23780
23790 STUPOS: MOVEM B,CHBUFS(A) ;[UT] SAVE BUFFER LOADS
23800 HRRM B,USETIX ;[UT] TELL USETI HOW MUCH TO DO
23810 MOVE C,INCH ;[UT] GET INPUT CHANNEL
23820 DPB C,[POINT 4,USETIX,ACFLD] ;[UT] SET USETI UP FOR CHANNEL
23830 DPB C,[POINT 4,USETIY,ACFLD]
23840 DPB C,[POINT 4,USETIZ,ACFLD]
23850 JRST USETIX ;[UT] GO POSITION AND INPUT FILE
23860 REMOTE<
23870 USETIX: USETI X,X ;[UT] POSITION FILE
23880 USETIY: INPUT X, ;[UT] DO INPUT
23890 USETIZ: STATZ X,740000 ;[UT] INPUT ERROR?
23900 ERR2 AIN.8 ;[UT] YES
23910 JRST USETIR
23920 >
23930
23940 ; GTCPOS COMPUTES BYTE POSITION WITHIN THE BUFFER
23950 GTCPOS: ADDI B,2 ;[UT] HEAD OF BUFFER IS HERE
23960 HRRZ C,POINTR(A) ;[UT] SEE WHERE IT POINTS
23970 SUB C,B ;[UT] INTO BUFFER
23980 IMULI C,5 ;[UT] CONVERT INTO CHARS.
23990 SKIPE CHOCH(A) ;[UT] SEE IF ANY EXTRAS
24000 SUBI C,1 ;[UT] TAKE CARE OF IT
24010 LDB A,[POINT 6,POINTR(A),5] ;[UT] UPDATE POINTER
24020 MOVNS A
24030 ADDI A,44 ;[UT] COMPUTE BYTE POSITION
24040 IDIVI A,7
24050 ADD C,A ;[UT] COMPUTE POSITION IN THIS BUFFER
24060 POPJ P, ;[UT] RETURN BYTES ALREADY PROCESSED
24070 >
24080 PAGE
24090 SUBTTL QMANGR INTERFACE
24100
24110 IFE QALLOW <XLIST>
24120 ;## CODE TO ALLOW LISP USER'S TO CALL DEC'S QMANGR, ALLOWING
24130 ;## PRINTING OF FILES AND CREATION OF .JBS
24140 ;## SCANS ARG LIST SETTING UP THE APPROPRIATE PARAMETERS. IT
24150 ;## SAVE THE PDLS, SWAPS HI-SEGS FOR SYS:QMANGR AND
24160 ;## DOES A PUSHJ TO 400010. IT ALSO CHANGES .JBREN SO
24170 ;## THAT THE USER CAN RECOVER IN CASE OF QMANGR ERRORS.
24180 ;## ST WILL ALSO STILL WORK. REG 17 (SP) IS USED AS QMANGR'S
24190 ;## PDL. CORE IS CONTRACTED AFTER RETURN FROM QMANGR AND QUEUE
24200 ;## RESTORES APPROPRIATE REGS AND RETURNS NIL. ALTHOUGH
24210 ;## CODE FOR EXTENDED SWITCHES IS INCLUDED, MOST OF
24220 ;## IT IS TURNED OFF. USE AT YOUR OWN RISK. NOTE THAT
24230 ;## /LIST, /AFTER AND /DEAD REQUIRE SPECIAL CODE
24240 ;## THAT IS NOT INCLUDED. SEE APPROPRIATE
24250 ;## DEC DOCUMENTATION FOR FURTHER INFO. 6/12/73
24260
24270
24280 IFN QALLOW <
24290 IFNDEF QSWEXT <QSWEXT=0> ;## IF NOT DEFINED THEN DEFAULT IS NO EXTENDED
24300 IFE QSWEXT <NSWS==QTABL1>;## NUMBER OF ALLOWED SWITCHES
24310 IFN QSWEXT <NSWS==QTABL2>;## LENGTH OF EXTENDED TABLE
24320 IFNDEF QLSTOK <QLSTOK==0>
24330 IFNDEF QTIME <QTIME==0>
24340
24350
24360 ;%% THE FOLLOWING CODE IS AN ILLUSTRATION OF HOW
24370 ;%% EASY IT IS TO LOSE TRYING TO INTERFACE TO
24380 ;%% DEC SOFTWARE. THE FOLLOWING DEFINITIONS ALLOW
24390 ;%% TOO FEW WORDS FOR THE CURRENT FILE PARAMETER
24400 ;%% AREA; SEE THE DEFINITIONS AS COPIED FROM
24410 ;%% THE QMANGR SOURCE BELOW.
24420 COMMENT &
24430 INPPAR==32 ;## NUMBER OF WORDS IN INP AREA FOR INPUT REQUEST
24440 OUTPAR==24 ;## NUMBER WORDS IN MAIN AREA FOR OUTPUT REQUEST
24450 DIFPAR==INPPAR-OUTPAR ;## DIFFERENCE IN LENGTHS FOR MAIN AREA TYPES
24460 FILPAR==14 ;## NUMBER WORDS IN FILE PARAMTER AREA
24470
24480
24490
24500
24510 ;## LOCATIONS IN PARAMETER AREAS
24520 ;## MAIN AREA
24530 Q.MEM==0 ;## MEMORY FOR QMANGR
24540 Q.OPR==1 ;## REQUESTED OPERATION
24550 Q.LEN==2 ;## RH=NUMBER OF FILES IN REQUEST
24560 Q.DEV==3 ;## REQUESTED QUEUE
24570 Q.PPN==4 ;## PPN REQUESTING
24580 Q..JB==5 ;## .JB NAME
24590 Q.SEQ==6 ;## .JB SEQUENCE #
24600 Q.PRI==7 ;## EXTERNAL PRIORITY
24610 Q.PDEV==10 ;##
24620 Q.TIME==11 ;##
24630 Q.CREA==12 ;##
24640 Q.AFTR==13 ;## AFTER PARAMETER
24650 Q.DEAD==14 ;## DEADLINE PARAMETER
24660 Q.CNO==15
24670 Q.USER==16 ;## AND 17
24680 ;## INPUT SECTION OF MAIN PARAMETER AREA
24690 Q.IDEP==20 ;## RESTART AND DEPENDENCY PARAMTERS
24700 Q.ILIM==21 ;## CORE AND CPU, +1 IS LPT LIMIT AND CDP LIMIT
24710 ;## +2 IS PTP LIMIT AND PLOT LIMIT
24720 Q.IDDI==24 ;## THRU 31
24730 Q.IEND==31 ;## LAST LOC OF INP AREA
24740 ;## OUTPUT SEECTION OF MAIN PARAMETER AREA
24750 Q.OFRM==20 ;## FORM PARAMTER
24760 Q.OSIZ==21 ;## LH=LIMIT
24770 Q.ONOT==22
24780 Q.OEND==23 ;## LAST LOC OF OUTPUT AREA
24790 ;## FILE PARAMETER AREA (ONE FOR EACH FILE)
24800 Q.FSTR==0 ;## FILE STRUCTURE
24810 Q.FDIR==1 ;## THRU 6, DIRECTORY
24820 Q.FNAM==7 ;## FILE NAME
24830 Q.FEXT==10 ;## FILE EXTENSION
24840 Q.FRNM==11 ;## RENAME NAME (0)
24850 Q.FBIT==12
24860 Q.FMOD==13 ;## SPACING, FILE DISPOSAL, COPIES
24870 & ;%% END OF DELETED DEFINITIONS
24880
24890 ;%% THE FOLLOWING ARE AS COPIED FROM QMANGR (VERSION 34)
24900 ;%% ON 24 OCTOBER 1973
24910
24920 QDEFST==. ;%% WHERE TO RELOC TO AFTERWARDS
24930 RELOC 0 ;%% TO SAVE CORE AND AVOID CONFUSION
24940 ;%% COMMENTS BELOW ARE AS COPIED
24950 ;%% FROM QMANGR
24960 PHASE 0
24970 Q.ZER:! ;START OF QUEUE PARAMETER AREA
24980 Q.MEM:! BLOCK 1 ;HOLD XWD WINDOW BLOCK,WINDOW WORD INDEX
24990 Q.OPR:! BLOCK 1 ;OPERATION CODE
25000 QO.CRE==1 ;CREATION OPERATION
25010 QO.LST==4 ;LIST OPERATION
25020 QO.MOD==5 ;MODIFY OPERATION
25030 QO.KIL==6 ;KILL OPERATION
25040 QO.DEL==10 ;DELETE OPERATION
25050 QO.REQ==11 ;REQUEUE OPERATION
25060 QO.FLS==12 ;FAST LIST OPERATION
25070 Q.LEN:! BLOCK 1 ;LENGTHS IN AREA
25080 Q.DEV:! BLOCK 1 ;DESTINATION DEVICE
25090 Q.PPN:! BLOCK 1 ;PPN ORIGINATING REQUEST
25100 Q..JB:! BLOCK 1 ;.JB NAME
25110 Q.SEQ:! BLOCK 1 ;.JB SEQUENCE NUMBER
25120 Q.PRI:! BLOCK 1 ;EXTERNAL PRIORITY
25130 Q.PDEV:! BLOCK 1 ;PROCESSING DEVICE
25140 Q.TIME:! BLOCK 1 ;PROCESSING TIME OF DAY
25150 Q.CREA:! BLOCK 1 ;CREATION TIME
25160 Q.AFTR:! BLOCK 1 ;AFTER PARAMETER
25170 Q.DEAD:! BLOCK 1 ;DEADLINE TIMES
25180 Q.CNO:! BLOCK 1 ;CHARGE NUMBER
25190 Q.USER:! BLOCK 2 ;USER'S NAME
25200
25210 Q.I:! ;START OF INPUT QUEUE AREA
25220 Q.IDEP:! BLOCK 1 ;DEPENDENCY WORD
25230 Q.ILIM:! BLOCK 3 ;.JB LIMITS
25240 Q.IL:! ;END OF AREA NEEDED TO READ FOR MASTER QUEUE
25250 Q.IDDI:! BLOCK 6 ;.JB'S DIRECTORY
25260 Q.II:! ;START OF INPUT FILES AREA
25270
25280 PHASE Q.I
25290 Q.O:! ;START OF OUTPUT QUEUE AREA
25300 Q.OFRM:! BLOCK 1 ;FORMS REQUEST
25310 Q.OSIZ:! BLOCK 1 ;LIMIT WORD
25320 Q.OL:! ;END OF AREA NEEDED TO READ FOR MASTER QUEUE
25330 Q.ONOT:! BLOCK 2 ;ANNOTATION
25340 Q.FF:!
25350 PHASE 0
25360 Q.F:! ;DUPLICATED AREA FOR EACH REQUESTED FILE
25370 Q.FSTR:! BLOCK 1 ;FILE STRUCTURE
25380 Q.FDIR:! BLOCK 6 ;ORIGINAL DIRECTORY
25390 Q.FNAM:! BLOCK 1 ;ORIGINAL NAME
25400 Q.FEXT:! BLOCK 1 ;ORIGINAL EXTENSION
25410 Q.FRNM:! BLOCK 1 ;RENAMED FILE NAME (0 IF NOT)
25420 Q.FBIT:! BLOCK 1 ;BIT 0=PRESERVED BY QUEUE, REST=STARTING BIT
25430 Q.FMOD:! BLOCK 1 ;FILE SWITCHES
25440 X.LOG==1B1 ;FILE IS LOG FILE
25450 X.NEW==1B2 ;OK IF FILE DOESNT EXIST YET
25460 Q.FRPT:!BLOCK 2 ;/REPORT
25470
25480 Q.FLEN==.-Q.F
25490 DEPHASE
25500 PHASE 0
25510 Q.FDRM:! BLOCK 6 ;DIRECTORY MASK FOR MODIFY
25520 Q.FNMM:! BLOCK 1 ;FILE NAME MASK FOR MODIFY
25530 Q.FEXM:! BLOCK 1 ;EXTENSION MASK FOR MODIFY
25540 Q.FMDM:! BLOCK 1 ;MODIFIER MASK FOR MODIFY
25550 Q.FMLN==.-Q.F ;LENGTH OF MODIFY BLOCK
25560
25570 DEPHASE
25580 RELOC QDEFST ;%% MAKE UP FOR INCREASE IN LOCATION
25590 ;%% COUNTER
25600
25610 INPPAR==Q.II ;%% SIZE OF MINIMUM INPUT AREA
25620 OUTPAR==Q.FF ;%% SIZE OF MINIMUM OUTPUT AREA
25630 OUTPR1==OUTPAR-1 ;%% MACRO DOESN'T LIKE EXPRESSIONS
25640 DIFPAR==INPPAR-OUTPAR ;%% DIFFERENCE IN AREAS
25650 FILPAR==Q.FLEN ;%% FILE DATA AREA
25660 LOWLEN==↑D110 ;## AREA NEED FOR PARAMETER
25670 ;## AREA TO QMANGR
25680 LHLEN==OUTPR1*1B26+FILPAR ;## LH OF Q.LEN DEFAULTS
25690 NQS==6 ;## NUMBER OF QUEUES
25700
25710
25720 ;## QUEUE ERRORS
25730
25740 QILLSW: HLRZ A,(T) ;## GET SWITCH THAT CAUSED ERROR
25750 PUSHJ P,PRINT
25760 STRTIP [SIXBIT / =ILL. SWITCH SPEC.!/]
25770 PUSHJ P,CONCOR ;## SAVE THAT CORE
25780 QERR1: ERR2 [SIXBIT /ERROR IN QUEUE REQUEST!/]
25790
25800
25810
25820 QUEUE: SKIPN T,A ;## ERROR IF NO ARGS
25830 JRST QERR1
25840 PUSHJ P,DEVCHK ;## SEE IF QUEUE SPECIFIED
25850 JUMPE A,NOQUE ;## IF A=0 THEN NOT A QUEUE
25860 JUMPE B,NOQUE ;## IF B=0 THEN NOT A QUEUE
25870 MOVE AR2A,A
25880 HLRZ B,A ;## GET FIRST THREEE LETTERS
25890 MOVEI C,NQS ;## GET NUMBER OF PERMISSIBLE QUEUES
25900 SOJL C,NOQUE ;## IF EXHAUSTED TABLE, THEN NO QUEUE
25910 MOVE A,QSTABL(C) ;## PERMISSIBLE QUEUES
25920 JSP R,CHKGO ;## JUMP TO ROUTINE THAT COMPARES RH AND GO
25930 ;## TO LH OF A IFF RH(A)=B
25940 JRST .-3 ;## LOOP
25950
25960
25970
25980 ;## TABLE OF PERMISSIBLE QUEUES AND WHERE TO GO ON EACH
25990
26000 QSTABL: XWD INPREQ, 'INP'
26010 XWD OUTREQ, 'LPT'
26020 XWD OUTREQ, 'PTP'
26030 XWD OUTREQ, 'PTP'
26040 XWD OUTREQ, 'CDP'
26050 XWD OUTREQ, 'PLT'
26060
26070 OUTREQ: TDZA A,A ;## HERE TO PROCESS OUTPUT REQUEST(CLEAR A)
26080 INPREQ: MOVEI A,DIFPAR ;## HERE TO PROCESS INPUT REQUEST
26090 JRST QGOOD ;## FOUND A QUEUE
26100 NOQUE: MOVSI AR2A,'LPT' ;## HERE IF NO QUEUE, DEFAULT=LPT
26110 TDZA A,A ;## CLEAR A AND SKIP
26120 QGOOD: HRRZ T,(T) ;## HERE IF QUEUE SPECIFIED
26130 ADDI A,OUTPAR ;## A IS ZERO OR INPPAR
26140 QSETUP: PUSH P,B ;## B CONTAINS THREE LETTERS(OR BLANK). SAVE IT
26150 HRLZI TT,(A) ;## SAVE LNENGTH OF AREA
26160 PUSHJ P,TEMCOR ;## EXPAND CORE
26170 HRRI TT,(A) ;## START ADDR OF MAIN AREA
26180 MOVE A,TT
26190 PUSHJ P,CLRBLK ;## CLEAR AREA
26200 MOVEM AR2A,Q.DEV(TT)
26210 MOVEI C,LHLEN ;## GET LENGTHS FOR HEADER AND FILE AREAS
26220 MOVE A,[XWD 500,500]
26230 HRLZM A,Q.OSIZ(TT) ;## ASSUME OUTPUT HERE
26240 POP P,B ;## RESTORE LEFT THREE LETTERS
26250 CAIE B,'INP' ;## WAS IT AN INPUT REQUEST?
26260 JRST QUEUE1 ;## NO SHOULD BE OK
26270 ADDI C,DIFPAR←9 ;## UPDATE HEADER LENGTH
26280 MOVEM A,Q.ILIM+1(TT) ;## MAX PAGES AND CARD PUNCH
26290 MOVEM A,Q.ILIM+2(TT) ;## MAX PAPER TAPE AND PLOTTER
26300 HRLI A,↑D256
26310 MOVEM A,Q.ILIM(TT) ;## MAX CORE AND CPU(CORMAX MAY HAVE TO BE
26320 ;## CHECKED HERE)
26330 MOVSI A,400000 ;## SET BIT 0 FOR NOT RESTARTABLE
26340 HLLZM A,Q.IDEP(TT) ;## NOT RESTARTABLE(NO DEPEND OR UNIQUENESS)
26350 QUEUE1: MOVSM C,Q.LEN(TT) ;## SET HEADER AND FILE AREA LENGTHS
26360 GETPPN A, ;## SET REQUESTING PPN
26370 CAI ;## WEIRD SKIP RETURN ON THIS UUO
26380 MOVEM A,Q.PPN(TT)
26390 SETZ REL, ;## CLEAR REG FOR FILE AREA
26400 MOVEI A,20 ;## PRIORITY DEFAULT
26410 MOVEM A,Q.PRI(TT)
26420 AOSA Q.OPR(TT) ;## SET DEFAULT FOR REQUEST TYPE=/CREATE
26430 ;## BASIC LOOP FOR HANDLING THE SWITCHES
26440
26450 QLOOP: HRRZ T,(T) ;## HERE IF ROUTINE DID NOT MOVE ARG
26460 QSELF: JUMPE T,QDONE
26470 PUSHJ P,DEVCHK ;## SEE IF DEVICE OR ATOMIC FILE NAME?
26480 JUMPN B,QFILEA ;## IF B#0 THEN DEVICE
26490 JUMPN A,QFILE ;## IF A#0 THEN ATOMIC FILE
26500 HLRZ C,(T) ;## WELL, SEE IF SWITCH
26510 HRRZ A,(C) ;## CDAR
26520 PUSHJ P,ATOM ;## ATOM?
26530 JUMPN A,QFILE ;## YES, THEREFORE(FILE.EXT)
26540 HLRZ B,(C) ;## CAAR
26550 SUBI B,(S) ;## STRIP OFF RELOCATION
26560 HRRZI C,NSWS ;## GET NUMBER OF SWITCHES
26570 QLOOP1: SOJL C,QFILE ;## IF NO SWITCH, GO QFILE
26580 MOVE A,QTABLE(C) ;## GET MEMBER OF TABLE
26590 JSP R,CHKGO
26600 JRST .-3 ;## LOOP
26610
26620
26630 ;## DISPATCH TABLE FOR SWITCHES
26640
26650 QTABLE:
26660 PHASE 1
26670 XWD QCOPIE,COPIES ;## /COPIES
26680 XWD QCPU,CPU ;## /CPU
26690 XWD QFORMS,FORMS ;## /FORMS
26700 XWD QLIMIT,LIMIT ;## /LIMIT
26710 QTABL1: XWD QDISP,DISP ;## /DISP (FILE DISPOSITION)
26720
26730 ;## EXTENDED SWITCHES
26740
26750 IFN QSWEXT <
26760 IFE QLSTOK <XWD QILLSW, LISTAT>
26770 IFN QLSTOK <XWD QLIST, LISTAT>
26780
26790 IFE QTIME <
26800 XWD QILLSW,AFTER ;## /AFTER ILLEGAL (SEE ABOVE)
26810 XWD QILLSW,DEAD ;## /DEAD (DEADLINE)
26820 >
26830
26840 IFN QTIME <
26850 XWD QAFTR,AFTER
26860 XWD QDEAD,DEAD
26870 >
26880 XWD QCORE,COREAT
26890 XWD QMOD,MODIFY ;## /MODIFY
26900 XWD QKILL,KILL ;## /KILL
26910 XWD Q.JB,.JB ;## /.JB
26920 XWD QDEPND,DEPEND ;## /DEPEND
26930 XWD QRSTR,RSTRT ;## /RESTART
26940 XWD QUNIQ,UNIQUE ;## /UNIQUE
26950 XWD QCORE,COREAT ;## /COREE
26960 XWD QPAGES,PAGES ;## /PAGES
26970 XWD QPLOT,PLOT ;## /PLOT
26980 XWD QPTAPE,PTAPE ;## /PTAPE
26990 XWD QCARDS,CARDS ;## /CARDS
27000 XWD QSEQ,SEQ ;## /SEQ
27010 XWD QPRIOR,PRIOR ;## /PRIOR (PRIORITY)
27020 XWD QSPACE,SPACE ;## /SPACE (SPACING)
27030 XWD QLIMIT,LIMIT ;## /LIMIT
27040 QTABL2: XWD QHEAD,HEAD ;## /HEAD (HEADERS)
27050 >
27060 DEPHASE
27070
27080 ;## DISPATCHING THE VARIOUS SWITCHES
27090
27100 IFN QSWEXT <QLIST: HRRZI A,4 ;## HERE FOR LIST REQUEST
27110 CAIA
27120 QMOD: HRRZI A, 5 ;## /MODIFY
27130 CAIA
27140 QKILL: HRRZI A, 6 ;## /KILL
27150 HRRZM A, Q.OPR(TT)
27160 JRST QLOOP
27170 >
27180
27190 ;## INPUT QUEUE ONLY SWITCHES
27200 ;## PUTS BYTE POINTER INTO B AND THEN CHECKS TO SEE IF SWITCH VALID IN
27210 ;## THIS CONTEXT (I.E. ARE WE PROCESSING AN INPUT REQUEST?)
27220 ;## IF NOT VALID, SKIPS THE SWITCH(MAY BE CHANGED LATER)
27230
27240 IFN QSWEXT <
27250 QPLOT: JSP R,RINPCH
27260 AOJA B, QCARD+1
27270 QPTAPE: JSP R, LINPCH
27280 AOJA B, .+4
27290 QCARDS: JSP R, RINPCH
27300 AOJA B, .+4
27310 QPAGES: JSP R, LINPCH
27320 AOJA B, .+4
27330 >
27340
27350 QCPU: JSP R, RINPCH
27360 AOJA B,QARG
27370
27380
27390 IFN QSWEXT <
27400 QCORE: JSP R, LINPCH
27410 AOJA B,QARG
27420 QDEPND: JSP R, RINPCH
27430 JRST QARG
27440 >
27450
27460 ;## OUTPUT QUEUE ONLY SWITCHES
27470 QFORMS: JSP R, OUTCHK
27480 PUSH P,QSXARG ;## CONVERT ARG TO SIXBIT
27490 MOVEM A, Q.OFRM(TT) ;## MAKE SIXBIT IF FORMS
27500 JRST QLOOP
27510 QLIMIT: JSP R, OUTCHK
27520 MOVE B,LINP
27530 AOJA B,QARG
27540
27550 OUTCHK: HLRZ A,Q.DEV(TT) ;## GET REQUEST TYPE (THREE LETTERS)
27560 CAIE A,'INP' ;## ERROR IF INPUT REQUEST
27570 JRST (R)
27580 JRST QILLSW
27590
27600 QCOPIE: JSP R, FILECH ;## CHECK IF WE HAVE SET UP A FILE AREA
27610 MOVE B,[POINT 6,Q.FMOD(REL),35] ;## BYTE POINTER
27620 JRST QARG
27630
27640
27650 ;## FOR DISPOSITION, 1=PRESERVE, 2=RENAME, 3=DELETE,
27660 ;## FIRST THREE LETTERS OF ARG TO SWITCH UNIQUELY IDENTIFY
27670 ;## ILLEGAL ARG CAUSES ERROR
27680 QDISP: JSP R,FILECH ;## BE SURE FILE AREA SET UP
27690 PUSHJ P,QSXARG ;## MAKE ARG SIXBIT
27700 HLRZ C,A ;## GET FIRST THREE LETTERS
27710 SETZ A, ;## CLEAR A
27720 CAIN C,'DEL' ;## DELETE AFTER OUTPUT!
27730 AOJA A,.+2 ;## YES!
27740 CAIN C,'REN' ;## RENAME FILE OUT OF UFD?
27750 AOJA A,.+3
27760 CAIE C,'PRE' ;## PRESERVE IT
27770 JRST QILLSW ;## HERE IF BAD ARGUMENT
27780 ADDI A,1
27790 MOVE B, [POINT 3, Q.FMOD(REL), 29]
27800 JRST QARG+1 ;## ARG ALREADY IN A
27810 ;## HERE WHEN SWITCH DETERMINED AND BITE POINTER IN B
27820 QGTARG: MOVEI A,(T)
27830 PUSHJ P,CADAR
27840 SUBI A,INUM0 ;## ARG SHOULD BE AN INUM
27850 POPJ P,
27860 QARG: PUSHJ P,QGTARG ;## GET ARGUMENT
27870 DPB A,B ;##
27880 JRST QLOOP ;## ALWAYS RETURN TO QLOOP
27890
27900 ;## HERE TO SEE IF INP QUEUE FOR EXTENDED PART OF MAIN AREA
27910
27920 LINPCH: MOVE B,LINP ;## GET LH BITE POINTER
27930 CAIA
27940 RINPCH: MOVE B,RINP ;## GET RH BITE POINTER
27950 HLRZ A,Q.DEV(TT) ;## GET QUEUE SPEC
27960 CAIN A,'INP' ;## INP?
27970 JRST (R) ;## YES
27980 JRST QILLSW
27990 LINP: POINT 18, Q.IDEP(TT),17 ;## BYTE POINTER FOR LEFT HALF OF EXTENDED MAIN AREA
28000 RINP: POINT 18, Q.IDEP(TT),35 ;## BYTE POINT FOR RH OF EXTENDED MAIN AREA
28010
28020
28030 ;## HERE TO BE SURE FILE AREA HAS BEEN SET UP
28040
28050 FILECH: JUMPN REL,(R) ;## REL NONZERO IF FILE AREA SET UP
28060 PUSH P,R
28070 JRST FILARE
28080 ;## HERE TO FIND FILE SPECIFICATION
28090
28100
28110 QFILEA: HRRZ T,(T) ;## GET CDR
28120 IFE SFDFLG,<SETZ B, ;## CLEAR B [UT]
28130 JRST QFILEB>
28140 IFN SFDFLG,<JRST QFILED> ;[UT] USE DEFAULT PATH
28150 IFE SFDFLG,<
28160 QFILE: MOVSI A,'DSK' ;## DEFAULT IS DSK
28170 CAIE REL,0 ;## AREA SET UP?
28180 SKIPA A,Q.FSTR(REL) ;## GET CURRENT DEVICE
28190 SKIPA B,Q.PPN(TT) ;## GET USER'S PPN IF NOT SET UP
28200 MOVE B,Q.FDIR(REL) ;## GET CURRENT PPN
28210 QFILEB: MOVEM B,PPN ;## SET PPN
28220 MOVEM A,DEV> ;## HANG ON TO DEVICE
28230
28240 IFN SFDFLG,<
28250 QFILE: JUMPE REL,QFILEC ;[UT] AREA SET UP?
28260 MOVE A,Q.FSTR(REL) ;[UT] NO, GET DEVICE
28270 MOVE B,[XWD Q.FDIR,PPN] ;[UT] MOVE PATH IN
28280 ADDI B,(REL) ;[UT] INDEX
28290 BLT B,PPN+SFDLEN ;[UT] MOVE THEM IN
28300 JRST QFILEB
28310 QFILEC: MOVSI A,'DSK' ;[UT] DEFAULT DEVICE
28320 QFILED: SETZM PPN ;[UT] USE DEFAULT PATH
28330 QFILEB: MOVEM A,DEV>
28340
28350 JUMPE T,QSELF ;## IF NIL THEN DONE
28360 PUSHJ P,NXTIO ;## FAKE IOSUB SEQUENCE
28370 PUSHJ P,IOPPN
28380 PUSH P,A ;## IOPPN RETURNS FILE NAME IN A
28390 CAIE REL,0 ;## AREA SET UP?
28400 SKIPE Q.FNAM(REL) ;## AREA SET UP, BUT NO FILE NAME?(PRECEDING SWITCHES)
28410 PUSHJ P,FILARE ;## SET UP AREA
28420 MOVE A,DEV ;## GET DEVICEE
28430 MOVEM A,Q.FSTR(REL) ;## SET FILE STRUCTURE
28440 MOVE A,EXT ;## GET EXTENSION
28450 MOVEM A,Q.FEXT(REL) ;## SET IT
28460 IFE SFDFLG,< ;[UT]
28470 MOVE A,PPN ;## GET PPN
28480 MOVEM A,Q.FDIR(REL)>
28490 IFN SFDFLG,<
28500 MOVE A,[XWD PPN,Q.FDIR] ;[UT] MOVE IT ALL IN
28510 ADDI B,(REL) ;[UT] INDEX
28520 BLT A,Q.FDIR+SFDLEN(REL)>
28530 ;## SET IT(DIRECTORY)
28540 POP P,Q.FNAM(REL) ;## RESTORE NAME
28550 JRST QSELF ;## T HAS BEEN RESET BY IO ROUTINES!
28560
28570
28580
28590 ;## HERE TO SET UP FILE AREA
28600
28610
28620 FILARE: AOS Q.LEN(TT) ;## ADD ONE TO NUMBER FILES IN REQUEST
28630 HRLZI A,FILPAR
28640 ADD TT,A ;## ADD TO LENGTH OF PARAMETER AREA
28650 HRRZI A,FILPAR
28660 PUSHJ P,EXPCOR
28670 JUMPE REL,FILDEF ;## SET DEFAULST IF NO PREVIOUS FILE AREA
28680 HRL A,REL
28690 HRRZI B,(A) ;## SET UP FOR BLT OF PREVIOUS AREA
28700 ADDI B,FILPAR-1 ;## FINAL DESTINATION ADDRESS
28710 HRRZI REL,(A) ;## NEW FILE AREA
28720 BLT A,(B)
28730 SETZM Q.FNAM(REL)
28740 POPJ P,
28750 FILDEF: HRRZI REL,(A)
28760 HRLI A,FILPAR
28770 PUSHJ P,CLRBLK
28780 HRLZI A,'DSK'
28790 MOVEM A,Q.FSTR(REL)
28800 MOVE A,[EXP 1B5+1B20+1B26+1B29+1] ;## DEFAULTS FOR Q.FMOD
28810 MOVEM A,Q.FMOD(REL)
28820 POPJ P,
28830
28840 ;## HERE WHEN FINISHED
28850
28860
28870 QDONE: MOVE AR1,OUTPAR+Q.FNAM(TT) ;## GET FIRST FILE NAME
28880 HLRZ A,Q.DEV(TT) ;## GET FIRST THREE LETTERS OF Q AGAIN
28890 CAIE A,'INP' ;## INPUT QUEUE?
28900 JRST QDONEB ;## NO
28910 MOVE AR1,INPPAR+Q.FNAM(TT) ;## GET CORRCT FILE NAME
28920 HRRZ A,Q.LEN(TT) ;## GET NUMBER OF FILES SPECIFIED
28930 SOJG A,QDONEC ;## GREATER THAN ONE MEANS THAT USER
28940 ;## SPECIFIED A LOG FILE
28950 PUSHJ P,FILARE ;## WE HAVE TO SET UP LOG FILE
28960 HRRZI A,'LOG' ;## CHANGE EXTENSION TO .LOG
28970 HRLZM A,Q.FEXT(REL)
28980 MOVEM AR1,Q.FNAM(REL) ;## SET TO INP FILE NAME
28990 QDONEC: HRRI A,3
29000 DPB A,[POINT 2,INPPAR+FILPAR+Q.FMOD(TT),2];## SET BITS
29010 ;## INDICATING LOG FILE AND DOESN'T EXIST
29020 ;## (AVOIDS ERROR MSGS FROM QMANGR)
29030 ;## IN SECOND FILE IN CASE USER STUPIDLY SET
29040 ;## UP MORE THAN TWO
29050 QDONEB: SKIPE Q..JB(TT) ;## SPECIFIED NAME
29060 JRST QDONE1 ;## YES, DONE
29070 MOVEM AR1,Q..JB(TT)
29080 QDONE1: MOVE C,[EXP 'QMANGR'];## SEGMENT NAME
29090 MOVEI B,400010
29100 MOVE A,TT
29110 PUSHJ P,NEWHI
29120 PUSHJ P,CONCOR ;## CONTRACT CORE
29130 SKIPN CCFLAG ;** ↑C HIT DURING QUEUE?
29140 JRST FALSE ;## RETURN NIL
29150 ;** YES: INFORM HIM THAT QUEUE IS BEING KILLED
29160 OUTSTR [ASCIZ /
29170 Exiting from QUEUE . . .
29180 /]
29190 POP P,CCFLG
29200 JRST CCINT1 ;** AND GO DO INTERRUPT
29210
29220
29230 ;## ROUTINE TO SWAP HI-SEGMENTS. A CONTAINS ARG TO NEXT HI-SEG, B CONTAINS
29240 ;## LOCATION TO JUMP TO IN NEW HI-SEG. REGS ARE ARG BLOCK TO GETSEG UUO
29250
29260 NEWHI: PUSH P,SP ;## HAVE TO SAVE SP, SINCE MOST
29270 ;## SYSTEM PROGS USE 17 FOR THEIR PDL
29280 MOVEM A,HIARGS# ;## SAVE ARG TO HI-SEG
29290 HRRZM B,HIADDR# ;## SAVE ADDR TO HI-SEG
29300 PUSH P,.JBFF ;%% SAVE OLD VALUE
29310 ;%% (DON'T ASK WHY)
29320 HLRZ B,A ;%% CALCULATE NEW VALUE
29330 ADDI B,1(A) ;%%
29340 MOVEM B,.JBFF ;%% RESET SO QMANGR WON'T WRITE
29350 ;%% OVER ARGUMENT BLOCK.
29360 ;%% JUST BECAUSE LISP IGNORES .JBFF
29370 ;%% DOESN'T MEAN ANYONE ELSE DOES
29380 MOVEM P,PSAVE# ;## SAVE P (CAN'T USE SP)
29390 MOVE SP,P ;## USE RPDL
29400 MOVEI A,CCINTQ ;** SET NEW ↑C TRAP LOCATION
29410 HRRM A,CCBLK ;**
29420 HRLZI B,'SYS' ;## SYS: IS LOCATION OF NEW HI-SEG
29430 MOVEI A,B ;## B IS STARTING LOCATION OF BLOCK TO GETSEG
29440 SETZB AR1,AR2A ;## CLEAR REST OF BLOCK
29450 SETZB T,TT ;## DITTO
29460 MOVEM SP,SAVSP# ;## SAVE SP AROUND GETSEG (WHICH CLOBBERS ACS)
29470 JRST NEWHI1 ;## GO DO IT
29480
29490 ;## HERE TO GET THAT HI-SEG
29500
29510 REMOTE <
29520 NEWHI1: CALLI A,GETSEG
29530 JRST OLDHI ;## FAILED (GIVE UP)
29540 MOVE SP,SAVSP
29550 MOVE A,HIARGS
29560 PUSHJ SP,@HIADDR ;## JUMP TO HI-SEG
29570 OLDHI: MOVEI A,HGHDAT
29580 CALLI A,GETSEG
29590 HALT ;## YOU'RE DEAD IF YOU ARE HERE
29600 ENDHI: JRST RESTOR ;## JUMP TO RESTORE THINGS
29610
29620 CCINTQ: SETOM CCFLAG ;** ↑C HIT: SET FLAG TO CAUSE DELAYED TRAP
29630 SETZM CCBLK+2 ;** RE-ENABLE ↑C TRAPPING
29640 JRST OLDHI ;** AND GO GET LISP'S HI-SEG
29650 >
29660
29670
29680 RESTOR: MOVE P,PSAVE
29690 POP P,.JBFF ;%% RESTORE OLD VALUE
29700 POP P,SP
29710 MOVE 0,STNIL
29720 MOVE S,ATMOV
29730 MOVEI A,CCINT ;** RESTORE ↑C INTERRUPT LOC
29740 HRRM A,CCBLK ;**
29750 POPJ P,
29760
29770
29780 TEMCOR: HRRZ B,CORUSE ;## GET CURRENT CORUSE. THIS ROUTINE EXPANDS CORE
29790 ;## BUT SAVE INFO SO IT CAN BE CONTRACTED LATER
29800 HRL B,.JBREL ;## GET CURRENT CORE EXTENT
29810 MOVEM B,OLDCU ;## SAVE IT (SEE LOADER INTERFACE)
29820 EXPCOR: SETZ D, ;## D IS A RELOC REG
29830 JRST MORCOR ;## EXPAND CORE
29840
29850 CONCOR: MOVS B,OLDCU ;## CONTRACTS CORE, OPPOSITE TEMCOR
29860 HLRZM B,CORUSE
29870 HRRZI B,(B) ;## CLEAR LH
29880 PUSHJ P,MOVDWN ;## MOVE SYMBOL TABLE
29890 CALLI B,CORE ;## CONTRACT (B SHOULD BE UNCHANGED
29900 CAI
29910 POPJ P, ;## DONE
29920
29930
29940 QSXARG: MOVEI A,(T)
29950 PUSHJ P,CADAR ;## GET ARGUMENT TO SWITCH
29960 JRST SIXMAK ;## CONVERT IT TO SIXBIT
29970
29980
29990
30000 CLRBLK: SETZM (A) ;## CLEAR FIRST WORD
30010 HLRZ B,A ;## LH OF A CONTAINS LENGTH
30020 ADD B,A
30030 HRL A,A
30040 AOJ A, ;## RH NOW CONTAINS SOURCE+1
30050 BLT A,-1(B) ;## BLT CLEARS BLOCK
30060 POPJ P,
30070 ;## PICKUP
30080
30090
30100 CHKGO: CAIN B,(A) ;## SEE IF RH(A)=(B)
30110 HLRZ R,A ;## WHERE TO GO
30120 JRST (R) ;## NO, RETURN
30130 >
30140 IFE QALLOW <LIST>
30150
30160 PAGE
30170 SUBTTL PRINT ROUTINES
30180
30190 ;** TOP-LEVEL PRINT FUNCTIONS:
30200
30210 TERPRI: PUSH P,A
30220 MOVEI A,CR
30230 PUSHJ P,TYO
30240 MOVEI A,LF
30250 PUSHJ P,TYO
30260 JRST POPAJ
30270
30280 LINES0: SKIPA A,[0] ;** (Get to start of new line)
30290 LINES: SUBI A,INUM0 ;** Output <n> blank lines
30300 PUSH P,A
30310 PUSHJ P,CHRPOS ;** At start of line?
30320 CAIE A,INUM0+1
30330 PUSHJ P,TERPRI ;** No, do a TERPRI to get there
30340 POP P,A
30350 SOJL A,FALSE ;** Return NIL when done
30360 PUSHJ P,TERPRI
30370 JRST .-2
30380
30390 EPRINT: MOVE B,RSTSW ;** DON'T PRINT IF *RSET = ERRORX
30400 CAIE B,ERRORX(S) ;**
30410 SKIPN ERRSW ;** ENTER HERE FOR "SERIOUS" PRINT
30420 POPJ P,
30430 EPRNT1: PUSHJ P,ERRIO
30440 PUSHJ P,PRINT
30450 JRST OUTRET
30460
30470 PRINTC: PUSHJ P,TERPRI ;** PRINTC
30480 PUSHJ P,PRINC
30490 JRST PRINT+2
30500
30510 PRINT: PUSHJ P,TERPRI
30520 PUSHJ P,PRIN1
30530 XCT " ",CTY
30540 POPJ P,
30550
30560 PRINC: SKIPA R,.+1
30570 PRIN1: HRRZI R,TYO ;LH(R) .NE. 0 if PRINC
30580 PUSH P,A
30590 PUSHJ P,CHRCT ;** Make sure CHCT is correct
30600 MOVE A,0(P) ;**
30610 PUSHJ P,PRINTA
30620 JRST POPAJ
30630
30640 PRINTA: PUSH P,A
30650 MOVEI B,PRIN3
30660 SKIPGE R
30670 MOVEI B,PRIN4
30680 HRRM B,PRIN5
30690 PUSHJ P,PATOM
30700 JUMPN A,PRINT1
30710 XCT "(",CTY
30720 PRINT3: HLRZ A,@(P)
30730 PUSHJ P,PRINTA
30740 HRRZ A,@(P)
30750 JUMPE A,PRINT2
30760 MOVEM A,(P)
30770 XCT " ",CTY
30780 PUSHJ P,PATOM
30790 JUMPE A,PRINT3
30800 XCT ".",CTY
30810 XCT " ",CTY
30820 PUSHJ P,PRIN1A
30830 PRINT2: XCT ")",CTY
30840 JRST POPAJ
30850 PRINT1: PUSHJ P,PRIN1A
30860 JRST POPAJ
30870 PAGE
30880 ;** LOWER-LEVEL PRINT FUNCTIONS:
30890
30900 PRIN1A: HRRZ A,-1(P) ;** (HRRZ instead of MOVE just in case)
30910 CAILE A,INUMIN
30920 JRST PRINIC
30930 IFE OLDNIL <
30940 CAIN A,NIL ;** IF NEW NIL THEN
30950 MOVEI A,FAKNIL(S) ;** GET FAKE ATOM HEADER
30960 >
30970 CAIGE A,@GCP1
30980 CAIGE A,@GCPP1
30990 JRST PRINL
31000 PRIN1B: HRRZ A,(A)
31010 JUMPE A,PRINL
31020 HLRZ B,(A)
31030 HRRZ A,(A)
31040 CAIN B,PNAME(S)
31050 JRST PRINN
31060 CAIN B,STRING(S) ;** NEW STRING REPRESENTATION
31070 JRST PSTR ;**
31080 CAIN B,FIXNUM(S)
31090 JRST PRINI1
31100 CAIN B,FLONUM(S)
31110 JRSTF @[XWD 0,PRINO] ; TURN OFF DIVIDE CHECK AND UNDERFLOW
31120 IFN BIGNMS<
31130 BPR: JRST PRIN1B ;bignums change here to JRST BPRINT>
31140 JRST PRIN1B
31150
31160 PRINL2: MOVEI R,TYO
31170 JRST PRINL1
31180
31190 PRINL: XCT "#",CTY
31200 HRRZ A,-1(P)
31210 PRINL1: MOVEI C,8
31220 JRST PRINI3
31230
31240 PRINI1: SKIPA A,(A)
31250 PRINIC: SUBI A,INUM0
31260 HRRZ C,VBASE(S)
31270 SUBI C,INUM0
31280 IFE BIGNMS<
31290 JUMPL C,[MOVNS C ;** NEW -BASE FEATURE
31300 JRST PRINI2]>
31310 JUMPGE A,PRINI2
31320 XCT "-",CTY
31330 MOVNS A
31340 PRINI2: SKIPE %NOPOINT(S) ;** NEW CODE TO PROVIDE OCTAL POINT
31350 JRST PRINI3
31360 MOVEI B,"."-"0"
31370 CAIN C,TEN
31380 JRST .+4
31390 CAIE C,10
31400 JRST PRINI3
31410 MOVEI B,"Q"-"0"
31420 HRLM B,(P)
31430 PUSH P,PRINI4
31440 PRINI3: LSHC A,-↑D35 ;** USE DIV FOR 1ST DIVIDE IN CASE
31450 LSH B,-1 ;** 36 BITS OF SIGNIFICANCE
31460 DIVI A,0(C) ;**
31470 JRST .+2 ;**
31480 IDIVI A,0(C)
31490 HRLM B,(P)
31500 SKIPE A
31510 PUSHJ P,.-3
31520 PRINI4: JRST FP7A1
31530
31540 PRINN: HLRZ A,(A)
31550 PUSHJ P,PRNSET ;** SET UP FOR UNPACKING
31560 ILDB A,C
31570 JUMPE A,CPOPJ ;special case of null character
31580 PRIN2X: LDB B,[POINT 1,CHRTAB(A),1]
31590 JUMPL R,PRIN4 ;never slash
31600 JRST PRIN2(B) ;1 for no slash
31610
31620 PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
31630 PRIN2: JRST PRINSL ;** GO PRINT A SLASH OR ITS EQUIVALENT
31640 PRIN4: PUSHJ P,(R)
31650 ILDB A,C
31660 JUMPN A,@PRIN5#
31670 POPJ P,
31680
31690 PRINSL: MOVE A,SLASHC ;** GET MOST RECENTLY-USED SLASH CHARACTER
31700 PUSHJ P,(R)
31710 LDB A,C
31720 JRST PRIN4
31730
31740 PSTR: PUSHJ P,PRNSET ;** SET UP FOR UNPACKING
31750 MOVE A,BSTRGC ;** GET STRING START CHAR
31760 SKIPL R ;** PRINC?
31770 PSTR1: PUSHJ P,(R) ;** PRINT CHAR
31780 ILDB A,C ;** GET NEXT
31790 JUMPN A,PSTR1 ;** LOOP UNTIL NULL FOUND
31800 MOVE A,ESTRGC ;** GET STRING END CHAR
31810 SKIPL R ;** PRINC?
31820 PUSHJ P,(R) ;** NO - PRINT IT
31830 POPJ P, ;** ALL DONE
31840
31850 ;** PUSH CHARACTERS ONTO STACK AND SET UP FOR UNPACKING
31860 PRNSET: MOVEI C,2(SP) ;** (2 in case called by EXPLODE)
31870 PUSHJ P,PNAMU3
31880 PUSH C,[0]
31890 HRLI C,(POINT 7,0,35)
31900 HRRI C,2(SP)
31910 POPJ P,
31920
31930 CTY: JSA A,TYOI
31940 REMOTE<
31950 TYOI: X
31960 JRST TYOI2>
31970 TYOI2: PUSH P,A
31980 LDB A,[POINT 6,-1(A),ACFLD]
31990 PUSHJ P,(R)
32000 POP P,A
32010 JRA A,(A)
32020
32030 PRINO: MOVE A,(A)
32040 CLEARB B,C
32050 JUMPG A,FP1
32060 JUMPE A,FP3
32070 MOVNS A
32080 XCT "-",CTY
32090 FP1: CAMGE A,FT01
32100 JRST FP4
32110 CAML A,FT8
32120 AOJA B,FP4
32130
32140 FP3: MULI A,400
32150 ASHC B,-243(A)
32160 MOVE A,B
32170 CLEARM FPTEM#
32180 PUSHJ P,FP7
32190 XCT ".",CTY
32200 MOVNI T,8
32210 ADD T,FPTEM
32220 MOVE B,C
32230
32240 FP3A: MOVE A,B
32250 MULI A,TEN
32260 PUSHJ P,FP7B
32270 SKIPE B
32280 AOJL T,FP3A
32290 POPJ P,
32300
32310 FP4: MOVNI C,6
32320 MOVEI TT,0
32330 FP4A: ADDI TT,1(TT)
32340 XCT FCP(B)
32350 TRZA TT,1
32360 FMPR A,@FCP+1(B)
32370 AOJN C,FP4A
32380 PUSH P,TT
32390 MOVNI B,-2(B)
32400 DPB B,[POINT 2,FP4C,34]
32410 PUSHJ P,FP3
32420 MOVEI A,"E"
32430 PUSHJ P,(R)
32440 MOVE A,FP4C#
32450 IORI A,51
32460 PUSHJ P,(R)
32470 POP P,A
32480 FP7: JUMPE A,FP7A1
32490 IDIVI A,TEN
32500 AOS FPTEM
32510 HRLM B,(P)
32520 JUMPE A,FP7A1
32530 PUSHJ P,FP7
32540
32550 FP7A1: HLRE A,(P)
32560 FP7B: ADDI A,"0"
32570 JRST (R)
32580
32590 353473426555 ;1e32
32600 266434157116 ;1e16
32610 FT8: 1.0E8
32620 1.0E4
32630 1.0E2
32640 1.0E1
32650 FT: 1.0E0
32660 026637304365 ;1e-32
32670 113715126246 ;1e-16
32680 146527461671 ;1e-8
32690 163643334273 ;1e-4
32700 172507534122 ;1e-2
32710 FT01: 175631463146 ;1e-1
32720 FT0:
32730 FCP: CAMLE A,FT0(C)
32740 CAMGE A,FT(C)
32750 XWD C,FT0
32760
32770 PAGE
32780 SUBTTL SUPER FAST TABLE DRIVEN READ 14-MAY-69
32790
32800 ;magic scanner table bit definitions
32810
32820 ;bit 0=0 iff slashified as nth id character
32830 ;bit 1=0 iff slashified as 1st id character
32840 ;bits 2-5 ratab index (scanning for atom)
32850 ;bits 6-8 dotab (and numfld) index (after dot or in number)
32860 ;bits 9-10 strtab index (in string)
32870 ;bits 11-13 idtab index (in atomic symbol)
32880 ;bits 14-16 exptab index (in exponent)
32890 ;bits 17-19 rdtab index (type of delimiter)
32900 ;bits 20-25 ascii to radix 50 conversion
32910
32920 REMOTE<
32930 BSTRGC: DBLQT ;** CURRENT STRING START
32940 ESTRGC: DBLQT ;** CURRENT STRING END
32950 SLASHC: "/" ;** CURRENT SLASH CHARACTER
32960 IGSTRT: IGCRLF
32970 IGEND: LF
32980 RATFLD: POINT 4,CHRTAB(A),5
32990 STRFLD: POINT 2,CHRTAB(A),10
33000 IDFLD: POINT 3,CHRTAB(A),13
33010 >
33020 DOTFLD:
33030 NUMFLD: POINT 3,CHRTAB(A),8
33040 EXPFLD: POINT 3,CHRTAB(A),16
33050 RDFLD: POINT 3,CHRTAB(A),19
33060 R50FLD: POINT 6,CHRTAB(A),25
33070
33080 ;magic state flags in t
33090 EXP==1 ;exponent
33100 NEXP==2 ;negative exponent
33110 SAWDOT==4 ;saw a dot (.)
33120 MINSGN==10 ;negative number
33130 SAWQ==20 ;** SAW A Q (OCTAL POINT)
33140
33150 IDCLS==0 ;identifier (must be zero)
33160 STRCLS==1 ;string
33170 NUMCLS==2 ;number
33180 DELCLS==3 ;delimiter
33190 EOLCLS==4 ;** End of line (for LINEREAD)
33200
33210 PAGE
33220 ;macros for scanner table
33230
33240 DEFINE RAD50 (X)<
33250 IFB <X>,<R50VAL=0>
33260 IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
33270 IFIDN <"X"><".">,<R50VAL=45>
33280 IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>
33290
33300 DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
33310 XLIST
33320 IRPC R50< RAD50 (R50)
33330 BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL>
33340 LIST>
33350
33360 DEFINE LET (X)<
33370 TABIN (1,1,5,2,3,4,2,0,X)>
33380
33390 DEFINE DELIMIT (X,Y)<
33400 TABIN (0,0,2,2,3,2,2,Y,X)>
33410
33420 DEFINE IGNORE (X)<
33430 TABIN (0,0,3,2,3,2,2,0,X)>
33440 PAGE
33450 REMOTE<CHRTAB:
33460 TABIN (0,0,1,1,1,1,1,0,< >)
33470 ;null
33480 LET (< >)
33490 IGNORE (< >)
33500 ;tab,lf,vtab,ff,cr
33510 LET (< >)
33520 ;16 to 30
33530 TABIN (0,0,0,0,0,0,0,0,< >)
33540 ;igmrk
33550 TABIN (0,0,0,0,0,0,0,0,< >)
33560 ;** 32 - An old IGMRK character
33570 IFE ALTMOD-33 <
33580 DELIMIT (< >,3)
33590 > ;%% NEW ALTMODE (5S06 MONITOR)
33600 IFN ALTMOD-33 <
33610 LET (< >)
33620 > ;%% OLD ALTMODE (5S04 OR EARLIER MONITOR)
33630 LET (< >)
33640 ;## 34 TO 37
33650 IGNORE (< >)
33660 ;space
33670 LET (< >)
33680 ;!
33690 TABIN (0,0,9,2,2,2,2,0,< >)
33700 ;"
33710 LET (< $% >)
33720 ;#$%&
33730 TABIN (1,0,2,2,3,4,2,5,< >)
33740 ;** ' now the quote character
33750 DELIMIT (< >,0)
33760 DELIMIT (< >,1)
33770 ;()
33780 LET (< >)
33790 ;*
33800 TABIN (1,1,14,2,3,4,2,0,< >)
33810 ;+
33820 IGNORE (< >)
33830 ;,
33840 TABIN (1,1,6,2,3,4,2,0,< >)
33850 ;-
33860 TABIN (0,0,7,3,3,2,2,4,<.>)
33870 TABIN (0,0,4,2,3,3,2,0,< >)
33880 ;/
33890 TABIN (1,0,8,5,3,4,3,0,<0123456789>)
33900 LET (< >)
33910 ;:;<=>?
33920 LET < >
33930 ;** @ now a normal character
33940 LET (<ABCD>)
33950 TABIN (1,1,5,4,3,4,2,0,<E>)
33960 LET (<FGHIJKLMNOP>)
33970 TABIN (1,1,5,6,3,4,2,0,<Q>)
33980 ;** SPECIAL ENTRY FOR Q = OCTAL POINT
33990 LET (<RSTUVWXYZ>)
34000 DELIMIT (< >,2)
34010 ;[
34020 LET (< >)
34030 ;\
34040 DELIMIT (< >,3)
34050 ;]
34060 LET (< >)
34070 ;↑←`
34080 LET (<ABCD>)
34090 ;lower case
34100 TABIN (1,1,5,4,3,4,2,0,<E>)
34110 ;** Allow e as well as E in numbers
34120 LET <FGHIJKLMNOP>
34130 TABIN (1,1,5,6,3,4,2,0,<Q>)
34140 ;** Allow octal point to be q as well as Q
34150 LET <RSTUVWXYZ>
34160 LET (< >)
34170 ;{|
34180 IFE ALTMOD-175 <
34190 DELIMIT (< >,3)
34200 > ;%% OLD ALTMODE (5S04 MONITOR)
34210 IFN ALTMOD-175 <
34220 LET (< >)
34230 > ;%% ⎇ - ORDINARY CHARACTER (5S06 MONITOR)
34240 LET (< >)
34250 ;}
34260 DELIMIT (< >,6)
34270 ;rubout
34280 >
34290 PAGE
34300 ;** TOP-LEVEL READ FUNCTIONS:
34310
34320 IASCII: PUSHJ P,NUMVAL ;** (ASCII WHICH INTERNS)
34330 SKIPA
34340 READCH: PUSHJ P,TYI
34350 LSH A,35 ;** (NEW, SMARTER CODE)
34360 MOVE C,SP
34370 PUSH C,A
34380 MOVEI R,IDCLS ;** MAKE IT A LITATOM
34390 JRST INTER0
34400
34410 READ0: PUSH P,TYI2 ;(** For use by READLIST type routines)
34420 PUSH P,OLDCH
34430 SETZM OLDCH#
34440 HRLI A,(JRST)
34450 MOVEM A,TYI2
34455 SETZM RAISEF# ;** No lower-case raising allowed
34460 PUSHJ P,READ1 ;** (changed from READ+1)
34470 POP P,OLDCH
34480 POP P,TYI2
34490 POPJ P,
34500
34510 REREAD: XCT OCR ;** Restarting a READ or LINEREAD
34520 MOVE P,PSAVAD# ;** Get saved P
34530 POP P,B ;** Get saved SP
34540 PUSHJ P,UBD ;** Unbind spdl (clears RH(PSAV) to 0)
34550 POPJ P, ;** And jump back to READ or LINEREAD
34560
34570 RDNAM: SETOM NOINFG ;## READ ROUTINE THAT DOES NOT INTERN
34580 MOVEI B,RDNAM ;** SET RE-START ADDRESS
34590 JRST READ+2 ;** AND GO START THE READ
34600
34610 READ: SETZM NOINFG# ;0 means intern
34620 MOVEI B,READ ;** SET RE-START ADDRESS
34630 MOVEI A,READ1 ;** SET START ADDRESS
34635 RDSTRT: SETOM RAISEF ;** LC RAISING UNDER CONTROL OF *RAISE
34640 SKIPE PSAV ;** ALREADY INSIDE A READ OR LINEREAD?
34650 JRST (A) ;** YES - WANT TO RESTART THERE, NOT HERE
34660 PUSH P,B ;** NO - SAVE RE-START ADDRESS
34670 PUSH P,SP ;** SAVE SPDL POINTER
34680 PUSH SP,[XWD PSAV,0] ;** FIX SO PSAV WILL BE RESET TO 0 ON ERROR
34690 PUSH SP,0(P) ;** STICK STACK SYNCHRONIZER ON
34700 HRRZM B,PSAV# ;** MAKE RH(PSAV) NON-ZERO FOR USE AS FLAG
34710 MOVEM P,PSAVAD# ;** AND SAVE RPDL STACK POINTER FOR REREAD
34720 SETZM EDFLAG ;** CLEAR AUTO EDIT FLAG
34730 PUSHJ P,(A) ;** GO DO THE READ
34740 RDDONE: POP P,SP ;** WHEN DONE RESTORE SP
34750 POP P,B ;** AND DISCARD SAVED RETURN ADDRESS
34760 SETZM PSAV ;** CLEAR PSAV
34770 SKIPN EDFLAG ;** AUTO EDIT KEY STRUCK?
34780 POPJ P, ;** NO, JUST RETURN
34790 PUSHJ P,QTIFY ;** YES: CONSTRUCT (EDITEXPR @exp)
34800 PUSHJ P,NCONS
34810 MOVEI B,EDITEXPR(S)
34820 PUSHJ P,XCONS
34830 JRST EVAL ;** AND GO EDIT EXPR BEFORE RETURNING IT
34840
34850
34860
34870 ;** LINEREAD - RETURNS ALL EXPRESSIONS ON LINE AS LIST
34880 ;** COPIED WITH SLIGHT MODIFICATIONS FROM CRIS PERDUE AT CMU
34890
34900 LINRD: JUMPE A,LINRDX ;** IF A=NIL REQUIRE INITIAL READ
34910 MOVEI A,LINRDP ;** A=T: LOAD START ADDRESS
34920 MOVEI B,LINRD+1 ;** LOAD RE-START ADDRESS
34930 JRST .+3 ;**
34940 LINRDX: MOVEI A,LINRD1 ;** A=NIL: LOAD START ADDRESS
34950 MOVEI B,LINRDX ;** LOAD RE-START ADDRESS
34960 SETZM NOINFG ;** (INTERN ALL ATOMS)
34970 JRST RDSTRT ;** AND GO START THE READ
34980
34990 LINRD1: PUSHJ P,READ1 ;READ ONCE
35000 LRNEXT: PUSH P,A
35010 PUSHJ P,LINRDP ;READ MORE, IF ANY
35020 POP P,B
35030 JRST XCONS
35040
35050 LINRDP: PUSHJ P,LRATOM
35060 JRST LRNEXT ;LRATOM READ SOMETHING, USE IT
35070 CAIN R,EOLCLS ;SPECIAL EOLCLS FOR LINEREAD MEANS DONE
35080 JRST FALSE
35090 XCT LRDTAB(B)
35100 MOVEM A,OLDCH
35110 JRST LINRD1 ;SOMETHING THERE, SO READ IT
35120
35130 LRDTAB: JFCL ;0 (
35140 JRST LINRDP ;1 )
35150 JFCL ;2 [
35160 JRST LINRDP ;3 ]
35170 JRST LINRDP ;4 .
35180 JFCL ;5 '
35190
35200 LRATOM: SKIPE SMAC ;COPY OF RATOM EXCEPT EOL HACKING AND COMMENTS
35210 JRST PSMAC ;IN THIS CASE (L)RATOM MAY RETURN LIST
35220 SETZB T,R
35230 HRLI C,(POINT 7,0,33) ;** (33 for null string)
35240 HRRI C,(SP)
35250 MOVEM C,ORGSTK ;SAVE FOR BACKING UP ON + OR -
35260 MOVEI AR1,1 ;SET UP MAGIC TYI BIT FOR LINENUMBERS
35270 SETZM LRCFLG ;NO LINE CONTINUE CHAR YET.
35280 LRATM2: PUSHJ P,TYIA
35290 CAIN A,ALTMODE ;** SPECIAL CHECK FOR ALTMODE
35300 JRST LREOL ;** (ACTS AS LINE TERMINATOR)
35310 LDB B,RATFLD
35320 JUMPE B,[ PUSHJ P,COMENT ;EAT COMMENT
35330 JRST LREOL] ;AND TERMINATE LINE
35340 CAIE B,3 ;TREAT IGNORE CHRS DIFFERENTLY
35350 JRST RATAB(B) ;IN MOST CASES THIS, THE RAT ACTION, HAPPENS
35360 CAIE A,SPACE ;** MAKE SP A LINE CONTINUER
35370 CAIN A,TAB
35380 JRST LRCONT
35390 CAIN A,","
35400 JRST LRCONT
35410 CAIN A,LF
35420 JRST LRLF
35430 CAIE A,CR ;CR - LEAVE FLAG ALONE, GO FOR LF
35440 LRNCNT: SETZM LRCFLG# ;ACTION FOR NON-CONTINUE CHAR
35450 JRST LRATM2
35460
35470 LRCONT: SETOM LRCFLG
35480 JRST LRATM2
35490
35500 LRLF: SKIPE LRCFLG
35510 JRST LRNCNT ;CONTINUE CALLED FOR
35520 LREOL: MOVEI R,EOLCLS
35530 AOS (P)
35540 POPJ P,
35550 PAGE
35560 ;** LOWER-LEVEL READ FUNCTIONS:
35570
35580 READ1: PUSHJ P,RATOM
35590 POPJ P, ;atom
35600 XCT RDTAB2(B)
35610 JRST READ1 ;try again
35620
35630 RDTAB2: JRST READ2 ;0 (
35640 JFCL ;1 )
35650 JRST READ4 ;2 [
35660 JFCL ;3 ],$
35670 JFCL ;4 .
35680 JRST RDQT ;5 '
35690
35700 READ2: PUSHJ P,RATOM
35710 JRST READ2A ;atom
35720 XCT RDTAB(B)
35730
35740 READ2A: PUSH P,A
35750 PUSHJ P,READ2
35760 POP P,B
35770 JRST XCONS
35780
35790 RDTAB: PUSHJ P,READ2 ;0 (
35800 JRST FALSE ;1 )
35810 PUSHJ P,READ4 ;2 [
35820 JRST READ5 ;3 ],$
35830 JRST RDT ;4 .
35840 PUSHJ P,RDQT ;5 '
35850
35860 RDTX: PUSHJ P,RATOM
35870 POPJ P, ;atom
35880 XCT RDTAB2(B)
35890 JRST DOTERR ;dot context error
35900
35910 RDT: PUSHJ P,RDTX
35920 PUSH P,A
35930 PUSHJ P,RATOM
35940 JRST DOTERR
35950 CAIN B,1
35960 JRST POPAJ
35970 CAIE B,3
35980 JRST DOTERR
35990 MOVEM A,OLDCH
36000 JRST POPAJ
36010
36020
36030 READ4: PUSHJ P,READ2
36040 MOVE B,OLDCH
36050 CAIE B,ALTMOD
36060 TYI1: SETZM OLDCH ;kill the ]
36070 POPJ P,
36080
36090 READ5: MOVEM A,OLDCH ;save ] or $
36100 JRST FALSE ;and return nil
36110
36120
36130 RDQT: PUSHJ P,READ1
36140 JRST QTIFY
36150 PAGE
36160 ;atom parser
36170
36180 COMENT: PUSHJ P,TYID
36190 CAME A,IGEND
36200 JRST COMENT
36210 POPJ P,
36220
36230 RATOM: SKIPE SMAC# ;$$ CHECK FOR A SPLICE MACRO LIST
36240 JRST PSMAC ;$$ GET ITEM FROM SPLICE MACRO LIST
36250 SETZB T,R ;** (Clear state flags and IDCLS -> R)
36260 HRLI C,(POINT 7,0,33) ;** (33 for null string)
36270 HRRI C,(SP)
36280 MOVEM C,ORGSTK# ;SAVE FOR BACKING UP ON + AND -
36290 MOVEI AR1,1 ;** (Magic bit for TYIA)
36300 RATOM2: PUSHJ P,TYIA
36310 LDB B,RATFLD
36320 JRST RATAB(B)
36330
36340 COMCHR==0 ;** COMMENT ENTRY FOR TYI AND MODCHR
36350 SLCHAR==4 ;** SLASH ENTRY FOR MODCHR
36360 STRBEG==↑D9 ;** STRING START FOR MODCHR
36370 RATAB: PUSHJ P,COMENT ;0 comment
36380 JRST RATOM2 ;1 null
36390 JRST RATOM3 ;2 delimit
36400 JRST RATOM2 ;3 ignore
36410 JRST RDIDSL ;4 / (** Ignore *RAISE flag)
36420 JRST RDID ;5 letter
36430 JRST RDNMIN ;6 -
36440 JRST RDOT ;7 .
36450 JRST RDNUM ;8 digit
36460 JRST RDSTR ;9 string
36470 JRST RMACRO ;10 MACRO
36480 JRST SMACRO ;11 SPLICE MACRO
36490 JRST RDNPLS ;12 +
36500
36510 ;a real dotted pair
36520 RDOT2: MOVEM A,OLDCH
36530 MOVE A,ORGSGN ;ORGSGN NORMALLY CONTAINS A "." AT THIS POINT
36540 RATOM3: LDB B,RDFLD
36550 HRRI R,DELCLS ;delimiter
36560 AOS (P) ;non-atom (ie a delimiter)
36570 POPJ P,
36580
36590 ;dot handler
36600 RDOT: MOVEM A,ORGSGN ;INCASE SOMETHING ELSE DEFINED AS "."
36610 PUSHJ P,TYID
36620 LDB B,DOTFLD
36630 JRST DOTAB(B)
36640
36650 DOTAB: PUSHJ P,COMENT ;0 comment
36660 JRST RDOT+1 ;1 null
36670 JRST RDOT2 ;2 delimit
36680 JRST RDOT2 ;3 dot
36690 JRST RDOT2 ;4 e
36700 JRST .+2 ;5 digit
36710 JRST RDOT2 ;6 Q (**)
36720 MOVEI B,0
36730 IDPB B,C
36740 TLO T,SAWDOT
36750 JRST RDNUM
36760
36770
36780 ;string scanner
36790 STREND==2 ;** STRING END FOR MODCHR
36800 STRTAB: PUSHJ P,COMENT ;0 comment
36810 JRST RDSTR ;1 null
36820 JRST STR2 ;2 delimit
36830 IDPB A,C ;3 string element
36840 RDSTR: PUSHJ P,TYID ;** NOTE THE " DELIMS ARE NOT STORED NOW
36850 LDB B,STRFLD
36860 JRST STRTAB(B)
36870
36880 STR2: HRRI R,STRCLS ;string
36890 SKIPE INTSTR(S) ;** ARE WE INTERNING STRINGS?
36900 JRST MKID ;** YES
36910 NOINTR: PUSHJ P,IDEND ;no intern
36920 PUSHJ P,IDSUB
36930 JRST PNAMAK
36940
36950
36960 ;identifier scanner
36970 IDTAB: PUSHJ P,COMENT ;0
36980 JRST RDID1 ;1 null
36990 JRST MAKID ;2 delimit
37000 JRST RDIDSL ;4 / (** No check for raising)
37010 RDID: SKIPE RAISEF ;4 letter or digit (** Raising allowed?)
37012 SKIPN RAISEV(S) ;** Yes: check *RAISE flag
37014 JRST RDIDSL+1 ;** Don't try to raise char
37020 CAILE A,140 ;** Is it a lower-case letter?
37022 CAILE A,172 ;**
37030 JRST RDIDSL+1 ;** Not lower case letter
37050 TRZA A,40 ;** Lower-case letter: raise it
37070 RDIDSL: PUSHJ P,TYI ;** Go read char after slash
37080 IDPB A,C
37090 RDID1: PUSHJ P,TYID
37100 LDB B,IDFLD
37110 JRST IDTAB(B)
37120 PAGE
37130
37140 ;## FUNCTIONS TO READ A FILE.EXT
37150 ;## READ A FILE.EXT FROM THE UFD
37160
37170 RDFILN: SETOM NOINFG ;** RDFILENAM -> No Intern
37180 JRST RDFIL1+1 ;**
37190 RDFILE: SETZM NOINFG ;** RDFILE -> Intern
37200 SKIPA ;**
37230 RDFIL1: PUSHJ P,FLTYIA ;## FILE NAME NOT THERE, SKIP OVER EXT
37240 PUSHJ P,FLTYIA ;## GET FILE NAME WORD
37250 JUMPE A,RDFIL1 ;** EMPTY FILENAME
37260 PUSHJ P,SIXATM+1 ;## MAKE IT AN ATOM (** +1 for NOINFG)
37270 PUSH P,A
37280 PUSHJ P,FLTYIA ;## GET EXTENSION
37290 HRRI A,0 ;## CLEAR RH
37300 JUMPE A,POPAJ ;** EMPTY EXTENSION
37310 PUSHJ P,SIXATM+1 ;** (+1 to leave NOINFG alone)
37320 POP P,B ;## GET FILE BACK
37330 JRST XCONS ;## RETURN FILE.EXT
37340
37341 FLTYIA: XCT TYI2 ;## GET NEXT WORD, IGNORE OLDCH
37342 JRST [SETZ AR1,
37343 JRST TYI2X ] ;%% INPUT SOME MORE, CLEARING TEST REG.
37344 ILDB A,@TYI3 ;## AND LOAD WORD
37345 POPJ P,
37346
37350 SIXCAT: ;[UT] MAKES A DEVICE NAME FROM LEFT JUSTIFIED SIXBIT
37360 MOVE B,[POINT 6,A] ;[UT] GO THROUGH EACH CHAR
37370 ILDB C,B
37380 JUMPN C,.-1 ;[UT] UNTIL YOU GET TO END
37390 MOVEI C,':' ;[UT] LOAD A COLON
37400 DPB C,B ;[UT] INTO NEXT POSITION
37410 ; JRST SIXATM ;[UT] AND MAKE ATOM
37420 ; FALLS THROUGH
37430
37440 ;## ROUTINE TO TAKE ONE WORD OF SIXBIT AND MAKE IT AN ATOM
37450 ;## IGNORES TRAILING BLANKS, BUT INCLUDES INSERTED BLANKS. NO
37460 ;## READ MACROS, ETC.
37470 ;** (THIS WAS SHORTENED CONSIDERABLY)
37480
37485 SIXATM: SETZM NOINFG ;** Normally want to intern
37490 HRLI C,(POINT 7,0,35) ;** INITIALIZE STACK POINTER
37500 HRRI C,(SP) ;**
37510 MOVE AR2A,[POINT 6,0,35] ;** SET UP TO LOAD BYTES FROM A
37520 SIXAT1: ILDB B,AR2A ;** GET A SIXBIT CHAR
37530 ADDI B,40 ;** CONVERT IT TO ASCII
37540 IDPB B,C ;** AND DEPOSIT IT
37550 SETZM B ;** CLEAR IT OUT OF A
37560 DPB B,AR2A ;**
37570 JUMPN A,SIXAT1 ;** GO GET MORE IF ANY
37580 MOVEI R,IDCLS ;** DONE: SET FOR LITATOM
37590 JRST MKID ;** AND MAKE ATOMIC SYMBOL
37600 PAGE
37610 ;NEW AND SUPER BITCHEN READ MACROS
37620 ;
37630 RMACRO:
37640 IFN ALVINE,<
37650 SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
37660 JRST RATOM2 ;$$ YES, IGNORE>
37670 RMAC2: PUSHJ P,READCH+1 ;** CONVERT THE CHAR TO AN ATOM
37680 MOVEM A,T ;$$ SAVE ATOM IN CASE OF ERROR
37690 MOVEI B,READMACRO(S) ;$$ GET THE FUNCTION NAME
37700 PUSHJ P,GET ;$$
37710 JUMPE A,RMERR ;$$ UNDEFINED READ MACRO
37720 PUSHJ P,NCONS ;$$ CONVERT TO A FORM
37725 PUSH P,RAISEF ;** SAVE RAISE FLAG
37730 PUSH P,NOINFG ;** Ch. from PSAV, which needn't be saved
37740 PUSHJ P,EVAL ;$$ EVALUATE THE FORM
37750 POP P,NOINFG ;** As you might suspect, also ch. from PSAV
37755 POP P,RAISEF ;** RESTORE RAISE FLAG TOO
37760 POPJ P, ;$$ RETURN
37770
37780 ;SPECIAL PROCESSING OF SPLICE MACROS
37790 SMACRO:
37800 IFN ALVINE,<
37810 SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
37820 JRST RATOM2 ;$$ YES, IGNORE>
37830 PUSHJ P,RMAC2 ;$$ EVALUATE THE MACRO
37840 MOVEM A,SMAC ;$$ SAVE THE SPLICE LIST
37850 JRST RATOM ;$$ START OVER
37860
37870 ;GET AN ITEM OFF OF THE SPLICE LIST
37880 PSMAC: MOVE A,SMAC ;$$
37890 PUSHJ P,ATOM ;$$ IS SPLICE LIST AN ATOM?
37900 JUMPN A,[ MOVE A,SMAC ;$$ YES, SIMULATE . <ATOM>
37910 PUSHJ P,NCONS ;$$
37920 MOVEM A,SMAC ;$$
37930 MOVEI B,4 ;$$
37940 JRST RATOM3+1] ;$$
37950 MOVE B,@SMAC ;$$
37960 HLRZ A,B ;$$ RETURN NEXT ITEM OF SPLICE LIST
37970 HRRZM B,SMAC ;$$ ADVANCE SPLICE LIST
37980 POPJ P, ;$$ RETURN
37990 PAGE
38000 ;number scanner
38010 NUMTAB: PUSHJ P,COMENT ;0 comment
38020 JRST RDNUM+1 ;1 null
38030 JRST NUMAK ;2 delimit
38040 JRST RDNDOT ;3 dot
38050 JRST RDE ;4 e
38060 JRST RDNUM ;5 digit
38070 JRST RDQ ;6 Q (**)
38080 RDNUM: IDPB A,C
38090 PUSHJ P,TYID
38100 LDB B,NUMFLD
38110 JRST NUMTAB(B)
38120
38130 RDNDOT: TLOE T,SAWDOT
38140 JRST NUMAK ;two dots - delimit
38150 MOVEI A,0
38160 JRST RDNUM
38170
38180 RDQ: CAMN C,ORGSTK ;** SAW A Q - CHECK FOR +Q AND -Q ATOMS
38190 JRST RDE+2 ;** NO DIGITS, SO MUST BE
38200 TLNE T,SAWDOT ;** HAVE WE ALREADY SEEN A DOT?
38210 JRST NUMAK ;** YES - Q IS A DELIMITER
38220 TLO T,SAWQ ;** NO - Q IS OCTAL POINT
38230 PUSHJ P,TYID ;** GO GET DELIMITER
38240 JRST NUMAK ;** AND MAKE NUMBER
38250
38260 RDNMIN: TLO T,MINSGN
38270 RDNPLS: MOVEM A,ORGSGN# ;SAVE SIGN IN CASE OF BACKUP
38280 JRST RDNUM+1
38290
38300 ;exponent scanner
38310 RDE: CAME C,ORGSTK ;FOR +E AND -E TYPE OF ATOMS
38320 JRST .+3
38330 MOVEM A,OLDCH
38340 JRST KLDG1
38350 TLO T,EXP
38360 MOVEI A,0
38370 IDPB A,C
38380 PUSHJ P,TYID
38390 CAIN A,"-"
38400 TLOA T,NEXP
38410 CAIN A,"+"
38420 JRST RDE2+1
38430 JRST RDE2+2
38440
38450 EXPTAB: PUSHJ P,COMENT ;0
38460 JRST RDE2+1 ;1 null
38470 JRST NUMAK ;2 delimit
38480 RDE2: IDPB A,C ;3 digit
38490 PUSHJ P,TYID
38500 LDB B,EXPFLD
38510 JRST EXPTAB(B)
38520 PAGE
38530 ;semantic routines
38540 ;identifier interner and builder
38550
38560 IDEND: TDZA A,A ;** (Fill out word with 0's)
38570 IDEND1: IDPB A,C
38580 TLNE C,760000
38590 JRST IDEND1
38600 POPJ P,
38610
38620 MAKID: MOVEM A,OLDCH
38630 MKID: SKIPE NOINFG
38640 JRST NOINTR ;dont intern it
38650 MKID1: PUSHJ P,IDEND ;** (MOVED FROM JUST AFTER MAKID)
38660 INTER0: PUSHJ P,IDSUB
38670 PUSHJ P,INTER1 ;is it in oblist
38680 POPJ P, ;found
38690 PUSHJ P,PNAMAK ;not there
38700 MAKID2: MOVE C,CURBUC# ;
38710 HLRZ B,@RHX2
38720 PUSHJ P,CONS ;cons it into the oblist
38730 HRLM A,@RHX2
38740 JRST CAR
38750
38760 ;pname unmaker
38770 PNAMUK: PUSHJ P,GETPNM ;** USE GETPNM TO GET PNAME
38780 MOVE R,D ;** SET CLASS TYPE (STRCLS OR IDCLS)
38790 MOVE C,SP
38800 PNAMU3: HLRZ B,(A)
38810 PUSH C,(B)
38820 HRRZ A,(A)
38830 JUMPN A,PNAMU3
38840 POPJ P,
38850
38860 ;idsub constructs a iowd pointer for a print name
38870 IDSUB: HRRZS C
38880 CAML C,JRELO ;top of spec pdl
38890 JRST SPDLOV
38900 MOVNS C
38910 ADDI C,(SP)
38920 HRLI C,1(SP)
38930 MOVSM C,IDPTR#
38940 POPJ P,
38950
38960 PAGE
38970 ;identifier interner
38980 INTER1: MOVE B,1(SP) ;get first word of pname
38990 LSH B,-1 ;right justify it
39000 IDIV B,INT1 ;compute hash code
39010 REMOTE<
39020 INT1: BCKETS
39030 RHX2:
39040 XXX1: XWD B+1,OBTBL>
39050 PUSH P,C ;## SAVE C
39060 HRRZ C,VOBLIST(S) ;## THIS GETS THE CURRENT VALUE OF OBLIST(THE ATOM)
39070 HRRM C,RHX2 ;## ASSUMES THAT ALL REFERENCE TO OBLIST GOES
39080 HRRM C,RHX5 ;## IE INTERN, REMOB ETC GOES THROUGH THIS SECTION.
39090 POP P,C ;##RHX2 AND RHX5 ARE HOPEFULLY THE ONLY TWO WORDS
39100 ;##WHICH ARE USED TO REFERENCE TABLE 3/28/73
39110 HLRZ TT,@RHX2 ;get bucket
39120 MOVEM B+1,CURBUC ;save bucket number
39130 MOVE T,TT
39140 MOVEI AR1,1 ;** SET RIGHT-BIT CLEARER
39150 JRST MAKID1
39160
39170 MAKID3: MOVE TT,T ;save previous atom
39180 HRRZ T,(T) ;get next atom
39190 MAKID1: JUMPE T,CPOPJ1 ;not in oblist
39200 HLRZ A,(T) ;next id in oblist
39210 PUSHJ P,CMPNAM ;** GO COMPARE PNAMES
39220 JRST MAKID3 ;** NOT THE SAME - TRY NEXT
39230 HLRZ A,(T) ;this is it
39240 HLRZ B,(TT)
39250 HRLM A,(TT) ;(** BUBBLE TOWARDS FRONT)
39260 HRLM B,(T)
39270 POPJ P,
39280
39290 ;** PNAME COMPARER
39300 CMPNAM: PUSHJ P,GETPNM ;** USE GETPNM TO GET PNAME
39310 CAME R,D ;** ARE THEY THE SAME TYPE?
39320 POPJ P, ;** NO - NO MATCH
39330 MOVE C,IDPTR ;found pname
39340 CMPNM1: JUMPE A,CPOPJ ;not the one
39350 MOVS A,(A)
39360 MOVE B,(A)
39370 ANDCAM AR1,(C) ;clear low bit
39380 CAME B,(C)
39390 POPJ P, ;not the one
39400 HLRZ A,A ;ok so far
39410 AOBJN C,CMPNM1
39420 JUMPE A,CPOPJ1 ;PNAMEs match
39430 POPJ P, ;not the one
39440
39450 PAGE
39460 ;pname builder
39470 PNAMAK: MOVE T,IDPTR
39480 PUSHJ P,NCONS
39490 MOVE TT,A
39500 MOVE C,A
39510 PNAMB: MOVE A,(T)
39520 TRZ A,1 ;clear low bit!!!!!
39530 PUSHJ P,FWCONS
39540 PUSHJ P,NCONS
39550 HRRM A,(TT)
39560 MOVE TT,A
39570 AOBJN T,PNAMB
39580 MOVE A,C
39590 CAIN R,STRCLS ;** BUILDING A STRING OR LITATOM?
39600 JRST .+3 ;** STRING
39610 HRLZS (A) ;** LITATOM
39620 JRST PNGNK1+1
39630 MOVEI B,STRING(S) ;**
39640 HRLM B,(A) ;**
39650 JRST ACONS ;**
39660
39670 ;** ROUTINE TO GET A PRINT NAME FROM A LITATOM OR STRING
39680 ;** LEAVES TYPE (IDCLS OR STRCLS) IN D
39690 GETPNM: MOVE C,A ;** SAVE ARG FOR ERROR PRINT
39700 CAILE A,INUMIN ;**
39710 JRST NOPNAM ;** ERROR IF INUM
39720 HRRZ B,(A)
39730 HLRZ D,(B)
39740 CAIE D,STRING(S)
39750 JRST .+4 ;** LITATOM
39760 MOVEI D,STRCLS ;** STRING
39770 HRRZ A,(B)
39780 POPJ P,
39790 MOVEI B,PNAME(S)
39800 PUSHJ P,GET
39810 JUMPE A,NOPNAM ;** ERROR IF LITATOM WITH NO PNAME
39820 MOVEI D,IDCLS
39830 POPJ P,
39840 PAGE
39850 ;number builder
39860 NUMAK: MOVEM A,OLDCH
39870 CAME C,ORGSTK ;BIG KLUDGE FOR + AND -
39880 JRST .+5
39890 KLDG1: MOVE A,ORGSGN ;ENTER HERE TO BACK UP IN THE CASE OF +E OR -E
39900 IDPB A,C
39910 PUSHJ P,TYIA
39920 JRST RDID1+1
39930 HRRI R,NUMCLS ;** (MOVED FROM ABOVE)
39940 MOVEI A,0
39950 IDPB A,C
39960 IDPB A,C
39970 HRRZS C
39980 CAML C,JRELO ;top of spec pdl
39990 JRST SPDLOV
40000 MOVSI C,(POINT 7,0,35)
40010 HRRI C,(SP)
40020 TLNE T,SAWDOT+EXP
40030 JRST NUMAK2 ;decimal number or flt pt
40040 MOVE A,VIBASE(S) ;ibase integer
40050 SUBI A,INUM0
40060 TLNE T,SAWQ ;** CHECK IF OCTAL POINT SEEN
40070 MOVEI A,10 ;** YES: BASE = 8
40080 PUSHJ P,NUM
40090 NUMAK4:
40100 MOVEI B,FIXNUM(S)
40110 NUMAK6: TLNE T,MINSGN
40120 MOVNS A
40130 JRST MAKNUM
40140
40150 NUMAK2: PUSHJ P,NUM10
40160 MOVEM A,TT
40170 TLNN T,SAWDOT
40180 JRST [ PUSHJ P,FLOATP ;flt pt without fraction (** lt 36 bits)
40190 MOVE TT,A
40200 JRST NUMAK3]
40210 SETZ AR2A, ;** CLEAR DIGIT COUNTER
40220 PUSHJ P,NUM10 ;fraction part
40230 EXCH A,TT
40240 TLNN T,EXP
40250 JUMPE AR2A,NUMAK4 ;no exponent and no fraction
40260 PUSHJ P,FLOATP ;** (lt 36 bits)
40270 EXCH A,TT
40280 PUSHJ P,FLOATP ;** (lt 36 bits)
40290 MOVEI AR1,FT01
40300 PUSHJ P,FLOSUB
40310 FMPR A,B
40320 FADRM A,TT
40330 NUMAK3: PUSHJ P,NUM10 ;exponent part
40340 IFE BIGNMS<
40350 JFCL 10,.+1 ;** CLEAR THE FLAG>
40360 MOVE AR2A,A
40370 MOVEI AR1,FT-1
40380 TLNE T,NEXP
40390 MOVEI AR1,FT01 ;-exponent
40400 PUSHJ P,FLOSUB
40410 FMPR TT,B ;positive exponent
40420 MOVEI B,FLONUM(S)
40430 MOVE A,TT
40440 JFCL 10,FLOOV
40450 JRST NUMAK6
40460
40470 FLOSUB: MOVSI B,(1.0)
40480 TRZE AR2A,1
40490 FMPR B,(AR1)
40500 JUMPE AR2A,CPOPJ
40510 LSH AR2A,-1
40520 SOJA AR1,FLOSUB+1
40530
40540 ;variable radix integer builder
40550 ;** CHANGED TO HANDLE 36-BIT INTEGERS (UNLESS BIGNMS SWITCH ON)
40560 ;** 37 BITS OR MORE CAUSES FIXOV ERROR
40570
40580 NUM10: MOVEI A,TEN
40590 NUM: HRRM A,NUM1
40600 IFN BIGNMS< JFCL 10,.+1> ;CLEAR FLAG IF CONCERNED ABOUT OVERFLOW
40610 SETZB A,B ;A=NUMBER, B=OVERFLOW
40620 NUM2: ILDB D,C ;GET A DIGIT
40630 JUMPE D,CPOPJ ;DONE IF NONE THERE
40640 JUMPL A,FIXOV ;ERROR IF ALREADY HAVE 36 BITS
40650 AOS AR2A ;INCREMENT DIGIT COUNTER
40660 IFN BIGNMS< IMUL A,NUM1#> ;IMUL TO CHECK FOR OVERFLOW
40670 IFE BIGNMS<
40680 MUL A,NUM1# ;MUL FOR 36 BITS
40690 EXCH A,B>
40700 ADDI A,-"0"(D)
40710 IFN BIGNMS<
40720 NUM3: JFCL 10,FIXOV ;bignums change this to jfcl 10,rdbnm>
40730 IFE BIGNMS<
40740 JUMPE B,NUM2 ;NO OVERFLOW BITS
40750 JUMPL A,FIXOV ;OVERFLOW - ERROR IF ALREADY HAVE 36 BITS
40760 TRNE B,777776 ;OR MORE THAN ONE OVERFLOW BIT
40770 JRST FIXOV
40780 TLO A,400000> ;OK - SET 36TH BIT
40790 JRST NUM2
40800 PAGE
40810 INTERN: MOVEM A,AR2A
40820 PUSHJ P,PNAMUK
40830 PUSHJ P,IDSUB
40840 PUSHJ P,INTER1 ;is it in oblist
40850 POPJ P, ;found it
40860 MOVE A,AR2A ;not there
40870 JRST MAKID2 ;put it there
40880
40890 REMOB: JUMPE A,FALSE
40900 PUSH P,A
40910 HLRZ A,(A)
40920 PUSHJ P,INTERN
40930 HLRZ B,@(P)
40940 CAME A,B
40950 JRST REMOB2
40960 CAIN A,NIL ;** AVERT POTENTIAL DISASTER
40970 ERR2 [SIXBIT /CAN'T REMOB NIL!/]
40980 HRRZ B,CURBUC
40990 REMOTE<
41000 RHX5:
41010 XXX2: XWD B,OBTBL>
41020 HLRZ C,@RHX5
41030 HLRZ T,(C)
41040 CAMN T,A
41050 JRST [ HRRZ TT,(C)
41060 HRLM TT,@RHX5
41070 JRST REMOB2]
41080 REMOB3: MOVE TT,C
41090 HRRZ C,(C)
41100 HLRZ T,(C)
41110 CAME T,A
41120 JRST REMOB3
41130 HRRZ T,(C)
41140 HRRM T,(TT)
41150 REMOB2: POP P,A
41160 HRRZ A,(A)
41170 JRST REMOB
41180
41190 ;** ROUTINE TO COMPARE PNAMES FOR EQUALITY WITHOUT INTERNING
41200 EQSTR: MOVE T,B ;SAVE 2ND ARG
41210 PUSHJ P,PNAMUK ;GET PNAME OF 1ST ARG
41220 PUSHJ P,IDSUB
41230 MOVEI AR1,1 ;SET RIGHT-BIT CLEARER
41240 MOVE A,T
41250 PUSHJ P,CMPNAM ;GO DO COMPARE
41260 JRST FALSE ;DIFFERENT
41270 JRST TRUE ;SAME
41280 PAGE
41290 ;ROUTINE TO ALLOW ARBITRARY MODIFICATION AND READING OF THE
41300 ;READ CHARACTER-TABLE BY LISP FUNCTIONS
41310 ;TAKES TWO ARGUMENTS A,B
41320 ; IF B = NIL IT RETURNS THE CONTENTS OF CHARACTER TABLE
41330 ; LOCATION SPECIFIED BY A
41340 ; OTHERWISE IT CHANGES THE CHARACTER TABLE ENTRY SPECIFIED BY A
41350 ; TO THE BIT PATTERN SPECIFIED BY B, AND RETURNS THE
41360 ; PREVIOUS VALUE
41380 MODCHR: PUSH P,B ;$$SAVE BIT PATTERN FOR TABLE
41390 PUSHJ P,NUMVAL ;$$GET POSITION IN TABLE
41400 POP P,B ;$$
41410 MOVE T,CHRTAB(A) ;$$GET OLD TABLE VALUE
41420 JUMPE B,MCEXIT ;$$IF B=NIL THEN JUST RETURN OLD TABLE VALUE
41430 PUSH P,A ;$$SAVE TABLE POSITION
41440
41450 MOVEI A,(B) ;$$
41460 PUSHJ P,NUMVAL ;$$GET NEW BIT PATTERN
41470 POP P,B ;$$GET TABLE POSITION
41480 MOVEM A,CHRTAB(B) ;$$CHANGE TABLE
41490 LDB A,[POINT 4,CHRTAB(B),5] ;** (RATFLD)
41500 CAIN A,SLCHAR ;** IS THIS A SLASH CHAR?
41510 MOVEM B,SLASHC ;** SAVE FOR SUBSEQUENT PRINTING
41520 CAIN A,COMCHR ;** IS IT A COMMENT START?
41530 MOVEM B,IGSTRT ;** SAVE FOR AUTO IGCRLF
41540 CAIN A,STRBEG ;** IS IT A STRING START?
41550 MOVEM B,BSTRGC ;** SAVE FOR PSTR
41560 LDB A,[POINT 2,CHRTAB(B),10] ;** (STRFLD)
41570 CAIN A,STREND ;** IS IT A STRING ENDER?
41580 MOVEM B,ESTRGC ;** SAVE FOR PSTR
41590 MCEXIT: MOVE A,T ;$$RETURN OLD TABLE VALUE
41600 JRST FIX1A ;$$CONVERT TO BINARY AND EXIT
41610
41620 ;FUNCTION TO DETERMINE THE ASCII VALUE OF A CHARACTER
41630 ; CHRVAL TAKES AN ATOM AS ITS ARGUMENT AND USES THE FIRST
41640 ; CHARACTER OF THE PRINT NAME
41650 CHRVAL: PUSHJ P,GETPNM ;** USE GETPNM TO GET PNAME
41660 HLRZ A,(A) ;$$
41670 LDB A,[POINT 7,(A),6] ;** GET FIRST CHARACTER
41680 JRST FIX1A ;$$ CONVERT TO INTEGER
41690
41700 ;FUNCTION TO SET BITS FOR A READ MACRO
41710 ; A IS THE CHAR. ATOM AND B ARE THE STATUS BITS,
41720 ; IF B=NIL NO MODIFICATION IS MADE
41730 ; THE OLD STATUS BITS ARE RETURNED
41740 SETCHR: MOVE TT,B ;$$
41750 PUSHJ P,CHRVAL ;$$ CONVERT CHAR. TO INUM
41760 MOVEI B,-INUM0(A) ;$$ CONVERT INUM TO BINARY
41770 LDB A,[POINT 5,CHRTAB(B),5] ;$$ LOAD OLD BITS
41780 JUMPE TT,FIX1A ;$$ NO CHANGE IF B = NIL
41790 MOVEI TT,-INUM0(TT) ;$$ CONVERT STATUS TO BINARY
41800 DPB TT,[POINT 5,CHRTAB(B),5] ;$$ SET NEW BITS
41810 JRST FIX1A ;$$ RETURN
41820 PAGE
41830 SUBTTL LISP INTERPRETER SUBROUTINES
41840
41850 CADDDR: SKIPA A,(A)
41860 CADDAR: HLRZ A,(A)
41870 CADDR: SKIPA A,(A)
41880 CADAR: HLRZ A,(A)
41890 CADR: SKIPA A,(A)
41900 CAAR: HLRZ A,(A)
41910 CAR: HLRZ A,(A)
41920 POPJ P,
41930
41940 CDDDDR: SKIPA A,(A)
41950 CDDDAR: HLRZ A,(A)
41960 CDDDR: SKIPA A,(A)
41970 CDDAR: HLRZ A,(A)
41980 CDDR: SKIPA A,(A)
41990 CDAR: HLRZ A,(A)
42000 CDR: HRRZ A,(A)
42010 POPJ P,
42020
42030 CAADDR: SKIPA A,(A)
42040 CAADAR: HLRZ A,(A)
42050 CAADR: SKIPA A,(A)
42060 CAAAR: HLRZ A,(A)
42070 JRST CAAR
42080
42090 CDADDR: SKIPA A,(A)
42100 CDADAR: HLRZ A,(A)
42110 CDADR: SKIPA A,(A)
42120 CDAAR: HLRZ A,(A)
42130 JRST CDAR
42140
42150 CAAADR: SKIPA A,(A)
42160 CAAAAR: HLRZ A,(A)
42170 JRST CAAAR
42180
42190 CDDADR: SKIPA A,(A)
42200 CDDAAR: HLRZ A,(A)
42210 JRST CDDAR
42220
42230 CDAADR: SKIPA A,(A)
42240 CDAAAR: HLRZ A,(A)
42250 JRST CDAAR
42260
42270 CADADR: SKIPA A,(A)
42280 CADAAR: HLRZ A,(A)
42290 JRST CADAR
42300 PAGE
42310 QUOTE: HLRZ A,(A) ;car and quote duplicated for backtrace
42320 POPJ P,
42330
42340 AASCII: PUSHJ P,NUMVAL
42350 LSH A,↑D29
42360 PUSHJ P,FWCONS
42370 PUSHJ P,NCONS
42380 PNGNK1: PUSHJ P,NCONS
42390 MOVEI B,PNAME(S)
42400 PUSHJ P,XCONS
42410 ACONS: TROA B,-1
42420 NCONS: TRZA B,-1
42430 XCONS: EXCH B,A
42440 CONS: HRL B,A ;** HRL and AOS switched to allow CONS+1 entry
42450 AOS CONSVAL
42460 SKIPN A,F
42470 JRST [ HLR A,B
42480 PUSHJ P,AGC
42490 JRST .-1]
42500 MOVE F,(F)
42510 MOVEM B,(A)
42520 POPJ P,
42530
42540 CONSP: JUMPE A,CPOPJ ;## DONE IF NIL
42550 CAIGE A,@GCP1 ;** MUST BE IN FS
42560 CAIGE A,@GCPP1 ;**
42570 JRST FALSE
42580 HLLE B,(A)
42590 AOJE B,FALSE
42600 IFN NONUSE <JRST TRUE> ;## T IF NONUSEFUL DESIRED
42610 IFE NONUSE <POPJ P,> ;## THE CELL OTHERWISE
42620 PATOM: CAIGE A,@GCP1 ;** T IF NOT IN FS
42630 CAIGE A,@GCPP1
42640 JRST TRUE
42650 JRST PATOM1
42660 ATOM: CAILE A,INUMIN
42670 JRST TRUE
42680 JUMPE A,TRUE ;## FAST CHECK FOR NIL
42690 ATOM1: CAIGE A,@GCP1 ;## LO-END OF FWS
42700 CAIGE A,@GCPP1 ;** LO-END OF FS
42710 JRST FALSE ;** NOT IN FS
42720 PATOM1: HLLE A,(A)
42730 AOJE A,TRUE
42740 FALSE: MOVEI A,NIL
42750 CPOPJ: POPJ P,
42760 PAGE
42770 NEQ: CAMN A,B
42780 JRST FALSE
42790 JRST TRUE
42800 EQ: CAMN A,B
42810 JRST TRUE
42820 JRST FALSE
42830
42840 LENGTH: MOVEI B,0
42850 LNGTH1: JUMPE A,FIX1 ;## DONE IF NIL
42860 CAIL A,@FWSO ;## FWSO IS FULL SPACE ORIGIN,
42870 ;## ELIMINATE ILL MEM REF
42880 JRST FIX1
42890 HLLE C,(A)
42900 AOJE C,FIX1
42910 HRRZ A,(A)
42920 AOJA B,LNGTH1
42930
42940 LAST: HRRZ B,(A)
42950 CAIE B,NIL ;## IF NIL DONE
42960 CAIL B,@FWSO ;## ANOTHER POTENTIAL ILL MEM GONE
42970 POPJ P,
42980 HLLE B,(B)
42990 AOJE B,CPOPJ
43000 HRRZ A,(A)
43010 JRST LAST
43020
43030 ;** LITATOM = ATOM, NOT STRING, NOT NUMBER
43040 ;** Leaves arg in B, doesn't change anything else
43050 LITATOM: CAILE A,INUMIN
43060 JRST FALSE ;** INUM
43070 MOVE B,A ;** SAVE A
43080 PUSHJ P,ATOM1-1 ;** ATOM?
43090 JUMPE A,CPOPJ ;** NON-ATOM
43100 HRRZ A,(B) ;** CHECK SPECIAL ATOMS
43110 HLRZ A,(A)
43120 CAIN A,STRING(S)
43130 JRST FALSE ;** STRING
43140 CAIE A,FIXNUM(S)
43150 CAIN A,FLONUM(S)
43160 JRST FALSE ;** NUMBER
43170 JRST TRUE
43180
43190 ;** STRINGP = ATOM, NOT LITATOM, NOT NUMBER
43200 STRNGP: CAILE A,INUMIN
43210 JRST FALSE
43220 MOVE B,A ;** SAVE A
43230 PUSHJ P,ATOM1 ;** NON-NIL ATOM?
43240 JUMPE A,CPOPJ
43250 STRNG1: HRRZ A,(B)
43260 HLRZ A,(A)
43270 CAIE A,STRING(S)
43280 JRST FALSE
43290 JRST TRUE
43300
43310 ;** NUMBERP = ATOM, NOT LITATOM, NOT STRING
43320 NUMBERP: PUSHJ P,NUMTYP ;[UT] GET THE TYPE OF NUMBER
43330 JUMPN A,TRUE ;[UT] IF IT'S A NUMBER
43340 NUMBP2: JRST FALSE ;bignums change this to JRST BIGNP
43350 PAGE
43360 ;NEW RPLACD AND RPLACA WHICH CHECK SO AS NOT TO CLOBBER NIL AND ATOMS
43370 RPLACA: CAIE A,NIL ;## TEST FOR NIL
43380 CAILE A,INUMIN ;$$
43390 JRST RPAERR ;$$ ATTEMPT TO RPLACA A SMALL NUMBER
43400 HLL A,(A) ;$$TEST FOR OTHER ATOMS
43410 TLC A,-1 ;$$
43420 TLZN A,-1 ;$$ATOM CARS ARE -1
43430 JRST RPAERR ;$$ATTEMPT TO RPLACA AN ATOM
43440 HRLM B,(A) ;$$STANDARD CODE FOR RPLACA
43450 POPJ P, ;$$
43460
43470 RPLACD: CAIG A,INUMIN ;$$CHECK FOR SMALL BER
43480 JUMPN A,.+2 ;$$CHECK FOR NIL
43490 JRST RPDERR ;$$ATTEMPT TO RPLACD NIL OR A SMALL NUMBER
43500 HRRM B,(A) ;$$OLD RPLACD CODE
43510 POPJ P, ;$$
43520
43530 ZEROP: PUSHJ P,NUMVAL
43540 NOT:
43550 NULL: JUMPN A,FALSE
43560 TRUE: MOVEI A,TRUTH(S)
43570 POPJ P,
43580
43590 FW0CNS: MOVEI A,0
43600 FWCONS: JUMPN FF,FWC1
43610 EXCH A,FWC0#
43620 PUSHJ P,AGC
43630 EXCH A,FWC0
43640 FWC1: EXCH A,(FF)
43650 EXCH A,FF
43660 POPJ P,
43670
43680 ;A COUPLE OF FUNCTIONS SO THAT THE PROGRAMMER MAY RETURN CELLS TO THE FREE LIST
43690 FREE: MOVEM F,(A) ;$$ RETURN A SINGLE CELL TO FREE LIST
43700 HRRZ F,A
43710 SOS CONSVAL ;** Decrement CONS count
43720 JRST FALSE
43730 FREELI: JUMPE A,CPOPJ ;$$ RETURN A LIST TO THE FREE LIST
43740 HRRZ B,(A)
43750 MOVEM F,(A)
43760 HRRZ F,A
43770 SOS CONSVAL ;** Decrement CONS count
43780 MOVE A,B
43790 JRST FREELI
43800 PAGE
43810 SASSOC: PUSHJ P,SAS1
43820 SKIPA A,C ;** USE APPLY INSTEAD OF UUO
43830 POPJ P,
43840 MOVEI B,NIL
43850 JRST AP2
43860
43870 ASSOC: PUSHJ P,SAS1
43880 MOVEI A,NIL
43890 POPJ P,
43900
43910 SAS0: HLRZ B,T
43920 SAS1: JUMPE B,CPOPJ
43930 MOVS T,(B)
43940 MOVS TT,(T)
43950 CAIE A,(TT)
43960 JRST SAS0
43970 HRRZ A,T
43980 CPOPJ1: AOS (P)
43990 POPJ P,
44000
44010 REVERSE: MOVE T,A
44020 MOVEI A,0
44030 JUMPE T,CPOPJ
44040 HLRZ B,(T)
44050 HRRZ T,(T)
44060 PUSHJ P,XCONS
44070 JUMPN T,.-3
44080 POPJ P,
44090 PAGE
44100 GET:
44110 IFE OLDNIL< CAIN A,NIL ;** IF NEW NIL GET FAKE ATOM HEADER
44120 MOVEI A,FAKNIL(S)>
44130 HRRZ A,(A)
44140 GET1: MOVS D,(A)
44150 CAIN B,(D)
44160 JRST CADR
44170 HLRZ A,D
44180 HRRZ A,(A)
44190 JUMPN A,GET1
44200 POPJ P,
44210
44220 GETL: JUMPE B,FALSE ;$$ NIL LIST - NIL ANSWER
44230 IFE OLDNIL< CAIN A,NIL ;** IF NEW NIL GET FAKE ATOM HEADER
44240 MOVEI A,FAKNIL(S)>
44250 HRRZ A,(A)
44260 GETL0: HLRZ T,(A)
44270 MOVE C,B
44280 GETL1: MOVS TT,(C)
44290 CAIN T,(TT)
44300 POPJ P,
44310 HLRZ C,TT
44320 JUMPN C,GETL1
44330 HRRZ A,(A)
44340 HRRZ A,(A)
44350 JUMPN A,GETL0
44360 POPJ P,
44370
44380 REMPROP:
44390 IFE OLDNIL< CAIN A,NIL ;** IF NEW NIL GET FAKE ATOM HEADER
44400 MOVEI A,FAKNIL(S)>
44410 HRRZ T,(A)
44420 REMP2: MOVS TT,(T)
44430 CAIN B,(TT)
44440 JRA TT,REMP1
44450 HLRZ A,TT
44460 HRRZ T,(A)
44470 JUMPN T,REMP2
44480 JRST FALSE
44490
44500 REMP1: HRRM TT,(A)
44510 JRST TRUE
44520 PAGE
44530 PUTPROP:
44540 IFE OLDNIL< CAIN A,NIL ;** IF NEW NIL GET FAKE ATOM HEADER
44550 MOVEI A,FAKNIL(S)>
44560 PUSH P,B ;** SAVE B
44570 PUSHJ P,LITATOM ;** IS A LITATOM?
44580 JUMPE A,PUTERR ;** (LEAVES A IN B, C NOT CHANGED)
44590 MOVE T,B
44600 HRRZ A,(B)
44610 POP P,B ;** RESTORE B
44620 CSET3: MOVS TT,(A)
44630 HLRZ A,TT
44640 CAIN C,(TT)
44650 JRST CSET2
44660 HRRZ A,(A)
44670 JUMPN A,CSET3
44680 HRRZ A,(T)
44690 PUSHJ P,XCONS
44700 HRRZ B,C
44710 PUSHJ P,XCONS
44720 HRRM A,(T)
44730 JRST CADR
44740
44750 CSET2: CAIE C,VALUE(S)
44760 JRST CSET1
44770 HRRZ T,(B)
44780 HLRZ A,(A)
44790 HRRM T,(A)
44800 JRST PROG2
44810
44820 CSET1: HRLM B,(A)
44830 PROG2: MOVE A,B
44840 PROG1: POPJ P,
44850 PAGE
44860 DEFPROP: HRRZ B,(A)
44870 HRRZ C,(B)
44880 HLRZ A,(A)
44890 HLRZ B,(B)
44900 HLRZ C,(C)
44910 PUSH P,A
44920 PUSHJ P,PUTPROP
44930 JRST POPAJ
44940
44950 ;** New Super (DEFLIST <l> <defval> <prop>)
44960 DEFLIST: HRRZ B,(A)
44970 HRRZ C,(B)
44980 JUMPN C,.+4
44990 MOVE C,B ;** MISSING <defval> ==> T
45000 MOVEI B,TRUTH(S)
45010 SKIPA
45020 HLRZ B,(B)
45030 HLRZ A,(A)
45040 HLRZ C,(C)
45050 JUMPE A,CPOPJ
45060 PUSH P,B ;** SAVE DEFAULT VALUE
45070 PUSH P,C ;** SAVE PROPERTY
45080 DEFL1: PUSH P,A ;** SAVE LIST
45090 HLRZ A,(A) ;** GET ATOM OR (ATOM VALUE) PAIR
45100 HLLE AR1,(A) ;** ATOM OR PAIR?
45110 AOJE AR1,.+5 ;** ATOM - USE DEFAULT VALUE
45120 HRRZ B,(A) ;** PAIR - USE VALUE GIVEN
45130 HLRZ B,(B)
45140 HLRZ A,(A)
45150 SKIPA
45160 HRRZ B,-2(P)
45170 HRRZ C,-1(P)
45180 PUSHJ P,PUTPROP
45190 POP P,A
45200 HRRZ A,(A)
45210 JUMPN A,DEFL1
45220 CPOP2J: SUB P,[XWD 2,2]
45230 POPJ P,
45240
45250 ;** (DEFP A1 A2 PR) - PR can be atom or GETL list
45260 DEFP: HLRZ B,(A)
45270 PUSH P,B ;** Save A1
45280 HRRZ A,(A)
45290 HLRZ B,(A)
45300 PUSH P,B ;** Save A2
45310 HRRZ A,(A)
45320 PUSH P,A ;** Save (PR)
45330 HLRZ A,(A)
45340 PUSHJ P,ATOM ;** Is PR an atom?
45350 POP P,B
45360 SKIPN A
45370 HLRZ B,(B) ;** No - must be list, so get it
45380 POP P,A ;** Pick up A2
45390 PUSHJ P,GETL ;** And go do GETL
45400 JUMPE A,POPBJ ;** Return NIL if nothing found
45410 HLRZ C,(A) ;** Pick up property
45420 HRRZ A,(A)
45430 HLRZ B,(A) ;** Pick up value
45440 MOVE A,0(P) ;** Get A1
45450 PUSHJ P,PUTPROP
45460 JRST POPAJ
45470
45480 ;** (DEFV A B) = (PROGN (SETQ A 'B) 'A)
45490 DEFV: HRRZ B,(A)
45500 HLRZ B,(B)
45510 HLRZ A,(A)
45520 PUSH P,A
45530 PUSHJ P,SET
45540 JRST POPAJ
45550 PAGE
45560 EQUAL: MOVE C,P
45570 EQUAL1: CAMN A,B
45580 JRST TRUE
45590 MOVE T,A
45600 MOVE TT,B
45610 PUSHJ P,ATOM
45620 EXCH A,B
45630 PUSHJ P,ATOM
45640 CAMN A,B
45650 JRST EQUAL3
45660 EQUAL4: MOVE P,C
45670 JRST FALSE
45680
45690 EQUAL3: JUMPN A,EQ2
45700 PUSH P,T
45710 PUSH P,TT
45720 HLRZ A,(T)
45730 HLRZ B,(TT)
45740 PUSHJ P,EQUAL1
45750 JUMPE A,EQUAL4
45760 POP P,B
45770 POP P,A
45780 HRRZ A,(A)
45790 HRRZ B,(B)
45800 JRST EQUAL1
45810
45820 EQ2: PUSH P,T
45830 MOVE A,T
45840 PUSHJ P,NUMBERP
45850 JUMPE A,EQUAL4
45860 MOVE A,TT
45870 PUSHJ P,NUMBERP
45880 JUMPE A,EQUAL4
45890 MOVE A,(P)
45900 MOVEM C,(P)
45910 MOVE B,TT
45920 JSP C,OP
45930 JRST COMP3 ;** CHANGED FROM JUMPL 7/27/76
45940 JRST COMP3 ;** DITTO
45950
45960 COMP3: POP P,C
45970 CAME A,TT
45980 JRST EQUAL4
45990 JRST TRUE
46000 PAGE
46010 COMMENT ?
46020 ;## OLD SUBST AND COPY CODE THAT DID NOT WORK AS IT WAS
46030 ;## NOT PROTECTED FROM THE GARBAGE COLLECTOR. NASTY, NASTY.
46040 ;## REPLACED BY COMPILED LISP CODE
46050 SUBS5: HRRZ A,SUBAS
46060 POPJ P,
46070
46080 SUBST: MOVEM A,SUBAS#
46090 MOVEM B,SUBBS#
46100 SUBS0A: MOVE A,SUBAS
46110 MOVE B,SUBBS
46120 PUSH P,C
46130 MOVE A,C
46140 PUSHJ P,EQUAL
46150 POP P,C
46160 JUMPN A,SUBS5
46170 CAIE C,NIL ;## TEST FOR NIL
46180 CAILE C,INUMIN
46190 JRST EV6A
46200 HLLE T,(C)
46210 AOJN T,SUBS2
46220 EV6A: MOVE A,C
46230 POPJ P,
46240
46250 SUBS2: PUSH P,C
46260 HLRZ C,(C)
46270 PUSHJ P,SUBS0A
46280 EXCH A,(P)
46290 HRRZ C,(A)
46300 PUSHJ P,SUBS0A
46310 POP P,B
46320 JRST XCONS
46330
46340 COPY: MOVEI B,INUM0 ;$$ (SUBST 0 0 A)
46350 MOVEI C,INUM0
46360 EXCH A,C
46370 JRST SUBST
46380 ?
46390 PAGE
46400 ; NTHCHAR = THE BTH CHARACTER OF A.
46410 ; ** USED TO TREAT LITATOMS AS A SPECIAL CASE FOR EFFICIENCY
46420 ; ** BUT STRINGS WERE HANDLED INCORRECTLY. FIXED TO HANDLE
46430 ; ** ALL OBJECTS VIA PRINTA
46440 ANTHCHAR: SETOM AEXFLG# ;** ANTHCHAR RETURNS ASCII CODE
46450 SKIPA
46460 NTHCHAR: SETZM AEXFLG ;** NTHCHAR RETURNS ATOMIC SYMBOL
46470 SUBI B,INUM0
46480 JUMPGE B,NTH3
46490 MOVEM B,ORGSGN
46500 PUSH P,A
46510 PUSHJ P,%FLATSIZEC
46520 MOVEI B,1-INUM0(A)
46530 ADD B,ORGSGN
46540 POP P,A
46550 NTH3: JUMPLE B,FALSE ;** IN CASE N = 0 OR IS TOO BIG (NEG)
46560 MOVEM B,ORGSGN
46570 HRROI R,NTH5 ;I HOPE THIS IS RIGHT
46580 PUSHJ P,PRINTA
46590 HLRZ A,ORGSGN
46600 JUMPE A,FALSE ;** IN CASE N TOO BIG (POS)
46610 SKIPN AEXFLG ;** ATOM OR ASCII?
46620 JRST READCH+1 ;** CONVERT TO AN ATOM
46630 ADDI A,INUM0 ;** ASCII - MAKE IT AN INUM
46640 POPJ P,
46650
46660 NTH5: SOSN ORGSGN
46670 HRLOM A,ORGSGN
46680 POPJ P,
46690 PAGE
46700 NCONC: TDZA R,R
46710 APPEND: MOVEI R,.APPEND-.NCONC
46720 JUMPE T,FALSE
46730 POP P,B
46740 APP2: AOJE T,PROG2
46750 POP P,A
46760 PUSHJ P,.NCONC(R)
46770 MOVE B,A
46780 JRST APP2
46790
46800 .NCONC: JUMPE A,PROG2 ;** THIS IS *NCONC
46810 MOVE TT,A
46820 NCONC1: CAILE TT,INUMIN ;** Make sure not NCONCing to atom
46830 JRST NAPERR
46840 HLLE C,(TT)
46850 AOJE C,NAPERR
46860 MOVE C,TT
46870 HRRZ TT,(C)
46880 JUMPN TT,NCONC1
46890 HRRM B,(C)
46900 POPJ P,
46910
46920 .APPEND: JUMPE A,PROG2 ;** THIS IS *APPEND
46930 MOVEI C,AR1
46940 MOVE TT,A
46950 APP1: CAILE TT,INUMIN ;** Make sure not APPENDing to atom
46960 JRST NAPERR
46970 HLLE A,(TT)
46980 AOJE A,NAPERR
46990 HLRZ A,(TT)
47000 PUSH P,B
47010 PUSHJ P,CONS ;saves b
47020 POP P,B
47030 HRRM A,(C)
47040 MOVE C,A
47050 HRRZ TT,(TT)
47060 JUMPN TT,APP1
47070 JRST SUBS4
47080 PAGE
47090 ;NEW MEM-FUNCTIONS THAT RETURN THE TAIL OF THE LIST STARTING WHERE
47100 ; THE ELEMENT IS FOUND
47110
47120 IFE NONUSE<MEMBER:
47130 >
47140 MEMBR.: PUSHJ P,MEMB0
47150 SKIPE A
47160 MOVE A,SUBBS
47170 POPJ P,
47180
47190 IFN NONUSE<MEMBER:
47200 >
47210 MEMB0: MOVEM A,SUBAS#
47220 MEMB1: JUMPE B,FALSE
47230 MOVEM B,SUBBS#
47240 MOVE A,SUBAS
47250 HLRZ B,(B)
47260 PUSHJ P,EQUAL
47270 JUMPN A,CPOPJ
47280 MOVE B,SUBBS
47290 HRRZ B,(B)
47300 JRST MEMB1
47310
47320 IFN NONUSE<
47330 MEMQ: PUSHJ P,MEMB
47340 SKIPE A
47350 JRST TRUE
47360 POPJ P,
47370 >
47380 IFE NONUSE<MEMQ:
47390 >
47400 MEMB: EXCH A,B ;## NEW MEMQ THAT RETURN TAIL
47410 JUMPE A,FALSE
47420 MOVS C,(A)
47430 CAIN B,(C)
47440 POPJ P,
47450 HLRZ A,C ;** DOES NOT WORK WITH NON-LISTS
47460 JUMPN A,MEMB+1
47470 POPJ P,
47480
47490
47500
47510 PAGE
47520 IFN NONUSE<
47530 ;AND OR FUNCTIONS (AND#, OR#) THAT RETURN THE EXPRESSION
47540 ; THAT CAUSED THE FUNCTION TO EVALUATE TO TRUE
47550
47560 AND.: PUSHJ P,AND
47570 SKIPA
47580 OR.: PUSHJ P,OR
47590 HRRZ A,2(P)
47600 POPJ P,
47610 >
47620
47630 AND: HRLI A,TRUTH(S)
47640 OR: HLRZ C,A
47650 PUSH P,C
47660 ANDOR: HRRZ C,A
47670 JUMPE C,AOEND
47680 MOVSI C,(SKIPE (P))
47690 TLNE A,-1
47700 MOVSI C,(SKIPN (P))
47710 XCT C
47720 JRST AOEND
47730 MOVEM A,(P)
47740 HLRZ A,(A)
47750 PUSHJ P,EVAL
47760 EXCH A,(P)
47770 HRR A,(A)
47780 JRST ANDOR
47790
47800 AOEND: POP P,A
47810 IFN NONUSE <
47820 SKIPE A
47830 MOVEI A,TRUTH(S)
47840 >
47850 POPJ P,
47860 PAGE
47870 GENSYM: MOVE B,[POINT 7,GNUM,34]
47880 MOVNI C,4
47890 MOVEI TT,"0"
47900
47910 GENSY2: LDB T,B
47920 AOS T
47930 DPB T,B
47940 CAIG T,"9"
47950 JRST GENSY1
47960 DPB TT,B
47970 ADD B,[XWD 70000,0]
47980 AOJN C,GENSY2
47990
48000 GENSY1: MOVE A,GNUM
48010 JRST PNGNK1-2 ;** CH FROM PNGNK1
48020
48030 REMOTE<
48040 GNUM: ASCII /G0000/>
48050
48060 CSYM: HLRZ A,(A)
48070 PUSH P,A
48080 PUSHJ P,GETPNM ;** USE GETPNM TO GET PNAME
48090 HLRZ A,(A)
48100 MOVE A,(A)
48110 MOVEM A,GNUM
48120 JRST POPAJ
48130 PAGE
48140 LIST: MOVEI B,CEVAL(S)
48150 PUSH P,B
48160 PUSH P,A
48170 MOVNI T,2
48180 JRST MAPCAR
48190
48200 EELS: HLRZ TT,(T) ;interpret lsubr call
48210 JUMPE TT,UNDFUN ;** NIL NOT A VALID PROPERTY
48220 HRRZ A,(AR1)
48230 ILIST: MOVEI T,0
48240 JUMPE A,ILIST2
48250 ILIST1: PUSH P,A
48260 HLRZ A,(A)
48270 PUSH P,TT
48280 HRLM T,(P)
48290 PUSHJ P,EVAL ;EVALUATE ARGUMENT
48300 ILIST3: POP P,TT
48310 HLRE T,TT
48320 EXCH A,(P)
48330 HRRZ A,(A)
48340 SOS T
48350 JUMPN A,ILIST1
48360 ILIST2: JRST (TT)
48370 PAGE
48380 ; NEW AND SUPER POWERFUL MAP FUNCTIONS
48390 MAPCON: TLZ T,100000 ;** (SET BITS FOR TYPE OF MAP)
48400 JRST MAPLIST
48410 MAPCAN: TLZA T,100000
48420 MAPC: TLZA T,400000
48430 MAPCAR: TLZA T,400000
48440 MAP: TLZ T,200000
48450 ; INITIALIZE
48460 MAPLIST:SETCA T,T
48470 MOVEI A,(CALLF)
48480 DPB T,[POINT 4,A,30]
48490 MOVE B,P
48500 MOVE AR1,T
48510 HRL AR1,T
48520 SUB B,AR1
48530 PUSH P,B
48540 HRLM A,(B)
48550 PUSH P,T
48560 PUSH P,
48570 HRLZM P,(P)
48580 ; SET UP TO GET ARGUMENTS
48590 MAPL2: HRRZ T,-1(P) ;** (GET # OF ARGS FOR FUN CALL)
48600 MOVEI TT,-3(P) ;** (GET ADDR OF LAST ARG)
48604 MOVEI NACS,1 ;** PUT NIL INTO ARG REGS
48608 BLT NACS,NACS ;**
48610 ; MOVE ARGS TO REGS
48620 MPL3: MOVE D,(TT)
48630 JUMPE D,MPDN ;** (IF NIL WE'RE DONE)
48640 CAILE D,INUMIN ;** CHECK FOR BAD TAIL
48650 JRST MAPERR ;**
48660 HLLE R,0(D) ;**
48670 AOJE R,MAPERR ;**
48680 MOVEM D,(T) ;** (STASH ARG)
48690 MOVE D,(D) ;** (PICK UP CONTENTS)
48700 SKIPGE -1(P) ;** (CHECK IF CAR NEEDED)
48710 HLRZM D,(T) ;** (YES: STASH CAR)
48720 HRRZM D,(TT) ;** (AND SAVE CDR FOR NEXT ITERATION)
48730 ;** NOTE THIS IS DONE BEFORE CALL SO A
48740 ;** RPLACD WON'T SCREW THE MAP
48750 SUBI TT,1
48760 SOJG T,MPL3 ;** (MOVE TO NEXT ARG)
48770 XCT (TT) ;CALL THE FUNCTION
48780 LDB C,[POINT 2,-1(P),2]
48790 TRNE C,2
48800 JRST MAPL2
48810 ; ATTACH TO OUTPUT LIST
48820 SKIPN C
48830 PUSHJ P,NCONS
48840 JUMPE A,MAPL2
48850 HLR B,(P)
48860 HRRM A,(B)
48870 SKIPE C
48880 PUSHJ P,LAST
48890 HRLM A,(P)
48900 JRST MAPL2
48910 ; POP STACK AND RETURN
48920 MPDN: POP P,AR1
48930 MOVE P,-1(P)
48940 POP P,B
48950 SUBS4: HRRZ A,AR1
48960 POPJ P,
48970
48980 ;FAST MAP/MAPC FOR 2 ARGS - CALLED BY LAP CODE
48990 .MAP: TLZA A,400000 ;** SET LEFT BIT FOR MAP
49000 .MAPC: TLO A,400000 ;** SET LEFT BIT FOR MAPC
49010 PUSH P,A ;** SAVE FN AND TYPE BIT
49020 PUSH P,B ;** SAVE LIST
49030 .MAPLP: MOVEI NACS,1 ;** PUT NIL INTO ARG REGS
49040 BLT NACS,NACS ;**
49050 MOVE B,(P) ;** GET LIST
49055 JUMPE B,CPOP2J ;** STOP IF NIL
49060 MOVE A,B ;** MOVE TO A
49070 SKIPGE -1(P) ;** MAP?
49080 HLRZ A,(B) ;** NO, MAPC - MOVE TO CAR
49090 HRRZ B,(B) ;** TAKE CDR OF LIST
49100 MOVEM B,(P) ;** AND SAVE IT
49110 CALLF 1,@-1(P) ;** CALL FUNCTION
49120 JRST .MAPLP ;** AND LOOP
49200 PAGE
49210 PROG: PUSH P,PA3# ;** PA3 = REG PDL POINTER
49220 PUSH P,PA4# ;** LH(PA4) = BODY, RH(PA4) = NEXT STATEMENT
49230 HLRZ TT,(A) ;## TT HAS VARIABLE LIST
49240 HRRZ A,(A) ;## A HAS PROG BODY
49250 HRRM A,PA4
49260 HRLM A,PA4
49270 MOVE T,SP ;$$ADJUST SPDLSAV POINTER TO INCLUDE EVAL BLIP
49280 SUB T,[XWD 2,2] ;$$SO PA3,PA4 CAN BE RESTORED
49290 MOVEM T,SPSV# ;$$BY UNBIND
49300 JRST PG7B ;$$GO CHECK IF ANY VARIABLES TO BIND
49310 PG7A: HLRZ A,(TT)
49320 MOVEI AR1,0
49330 PUSHJ P,BIND
49340 HRRZ TT,(TT)
49350 PG7B: JUMPN TT,PG7A
49360 PUSH SP,SPSV
49370 MOVEM P,PA3
49380 PG1: HRRZ T,PA4
49390 JUMPE T,PG4 ;## IF END OF PROG, QUIT
49400 HLRZ A,(T) ;## A HAS FIRST STATEMENT
49410 HRRZ T,(T) ;## T KEEPS THE REST
49420 CAIE A,NIL ;## TEST FOR NIL
49430 CAILE A,INUMIN ;## ALLOW INUMS FOR PROG LABELS 3/28/73
49440 JRST PG1+1 ;## NOW WE CAN SKIP OVER THIS TYPE OF ATOM
49450 HLLE B,(A) ;## IS IT A ATOM?
49460 AOJE B,PG1+1 ;## JA, SO JUMP
49470 HRRM T,PA4 ;## SAVE REST OF BODY
49480 PUSHJ P,EVAL ;## EVAL THE STATEMENT
49490 JRST PG1
49500
49510 PGO: SKIPN PA3 ;## ERROR IF NO PROG
49520 JRST EG2
49530 MOVE P,PA3 ;## BACK UP ON RPDL
49540 MOVE B,2(P) ;** GET SP PUSHED BY EVAL
49550 PUSHJ P,UBD
49560 HRLZI C,(POPJ P,) ;## NEW CODE TO ALLOW BREAKING
49570 ;## AND TRACING OF GO
49580 PUSHJ P,DOSET ;##
49590 HLRZ T,PA4
49600 PG5: JUMPE T,EG1 ;## ERROR IF NO TAG FOUND
49610 HLRZ TT,(T) ;## GET THE CAR
49620 HRRZ T,(T) ;## SAVE UP THE REST OF THE BODY
49630 CAIN TT,(A)
49640 JRST PG1+1 ;FOUND TAG
49650 JRST PG5 ;## TRY AGAIN
49660
49670 RETURN: SKIPN PA3
49680 JRST EG3
49690 MOVE P,PA3
49700 MOVE B,2(P) ;** GET SP PUSHED BY EVAL
49710 PUSHJ P,UBD
49720 HRLZI C,(POPJ P,) ;## NEW CODE TO ALLOW BREAKING
49730 ;## AND TRACING OF RETURN
49740 PUSHJ P,DOSET ;##
49750 JRST PG4+1
49760
49770 PG4: SETZ A,
49780 PUSHJ P,UNBIND
49790 ERRP4: POP P,PA4
49800 POP P,PA3
49810 POPJ P,
49820
49830 GO: HLRZ A,(A)
49840 CAIE A,NIL ;## TEST FOR NIL
49850 CAILE A,INUMIN ;## IS IT AN INUM?(NOW VALID)
49860 JRST PGO ;## SEE IF IT IS THE ONE
49870 HLLE B,(A) ;## IS IT AN ATOM
49880 AOJE B,PGO
49890 PUSHJ P,EVAL
49900 JRST GO+1
49910
49920 SETQ: HLRZ B,(A)
49930 PUSH P,B
49940 PUSHJ P,CADR
49950 PUSHJ P,EVAL
49960 MOVE B,A
49970 POP P,A
49980 SET: MOVE AR1,B ;** ERROR CHECKS NOW DONE IN BIND
49990 PUSHJ P,BIND
50000 SUB SP,[XWD 1,1]
50010 MOVE A,AR1
50020 POPJ P,
50030
50040 CON2: HRRZ A,(T)
50050 COND: JUMPE A,CPOPJ ;entry
50060 PUSH P,A
50070 HLRZ A,(A)
50080 HLRZ A,(A)
50090 PUSHJ P,EVAL
50100 POP P,T
50110 JUMPE A,CON2
50120 HLRZ T,(T)
50130 COND2: HRRZ T,(T)
50140 JUMPE T,CPOPJ ;ENTRY FOR ALL TYPES OF PROGN'S
50150 HLRZ A,(T)
50160 HRRZ T,(T) ;$$
50170 JUMPE T,EVAL ;$$ SAVE STACK SPACE IF NO IMPLIED PROG
50180 PUSH P,T ;$$
50190 PUSHJ P,EVAL
50200 POP P,T
50210 JRST COND2+2 ;$$ BECAUSE OF THE LAST CHANGE
50220
50230 PROGN: MOVE T,A ;$$ PROGN
50240 MOVEI A,NIL
50250 JRST COND2+1 ;$$ IMPLIED PROG DOES THE REST
50260 PAGE
50270 ;LEXORDER - TRUE IF A IS ALPHAMERICALLY LESS THAT OR EQUAL TO B
50280 ;** FIXED TO HANDLE LISTS BY FINDING LEFT-MOST ATOM
50290
50300 LEXORD: MOVE T,B ;** SAVE 2ND ARG IN T
50310 MOVE TT,A ;** SAVE 1ST ARG IN TT
50320 PUSHJ P,ATOM ;** IS 1ST ARG AN ATOM?
50330 JUMPN A,.+3 ;**
50340 HLRZ A,(TT) ;** NO - MOVE DOWN THE CAR
50350 JRST .-4 ;** UNTIL AN ATOM IS REACHED
50360 MOVE A,T ;**
50370 PUSHJ P,ATOM ;** IS 2ND ARG AN ATOM?
50380 JUMPN A,.+3 ;**
50390 HLRZ T,(T) ;** NO - MOVE DOWN CAR
50400 JRST .-4 ;**
50410 MOVE A,TT
50420 PUSHJ P,NUMBERP
50430 JUMPN A,LEX2 ;1ST ARG IS A NUMBER
50440 MOVE A,T
50450 PUSHJ P,NUMBERP
50460 EXCH A,TT
50470 JUMPN TT,FALSE ;1ST=NOT-NUM, 2ND=NUM, DEFINE AS NIL
50480 PUSHJ P,GETPNM ;** USE GETPNM TO GET PNAME
50490 EXCH A,T
50500 PUSHJ P,GETPNM ;** DITTO
50510 LEX1: JUMPE T,TRUE
50520 JUMPE A,CPOPJ
50530 HLRZ AR1,(A)
50540 MOVE AR1,(AR1)
50550 HLRZ AR2A,(T)
50560 MOVE AR2A,(AR2A)
50570 LSH AR1,-1
50580 LSH AR2A,-1
50590 CAMLE AR1,AR2A
50600 JRST TRUE
50610 CAME AR1,AR2A
50620 JRST FALSE
50630 HRRZ A,(A)
50640 HRRZ T,(T)
50650 JRST LEX1
50660 LEX2: MOVE A,T ;**
50670 PUSHJ P,NUMBERP ;** (LEAVES A IN B)
50680 EXCH A,TT
50690 JUMPE TT,TRUE ;1ST=NUM, 2ND=NOT-NUM, DEFINE AS TRUE
50700 MOVE B,T ;**
50710 PUSHJ P,.GREAT ;BOTH NUMBERS, DO (NOT (*GREAT A B))
50720 JRST NOT
50730 PAGE
50740 SUBTTL ARITHMETIC SUBROUTINES
50750
50760 ;macro expander -- (foo a b c) => (*foo (*foo a b) c)
50770 EXPAND: MOVE C,B
50780 HRRZ A,(A)
50790 PUSHJ P,REVERSE
50800 JRST EXPA1
50810
50820 EXPN1: MOVE C,B
50830 EXPA1: HRRZ T,(A)
50840 HLRZ A,(A)
50850 JUMPE T,CPOPJ
50860 PUSH P,A
50870 MOVE A,T
50880 PUSHJ P,EXPA1
50890 EXCH A,(P)
50900 PUSHJ P,NCONS
50910 POP P,B
50920 PUSHJ P,XCONS
50930 MOVE B,C
50940 JRST XCONS
50950
50960 PAGE
50970
50980 ADD1: CAILE A,INUMIN
50990 CAIL A,-2
51000 SKIPA B,[INUM0+1]
51010 AOJA A,CPOPJ
51020 .PLUS: JSP C,OP
51030 ADD A,TT
51040 FADR A,TT
51050
51060 SUB1: CAILE A,INUMIN+1
51070 SOJA A,CPOPJ
51080 MOVEI B,INUM0+1
51090 .DIF: JSP C,OP
51100 SUB A,TT
51110 FSBR A,TT
51120
51130 .TIMES: JSP C,OP
51140 IMUL A,TT
51150 FMPR A,TT
51160
51170 .QUO: CAIN B,INUM0
51180 JRST ZERODIV
51190 JSP C,OP
51200 IDIV A,TT
51210 FDVR A,TT
51220
51230 .GREAT: EXCH A,B
51240 JUMPE B,FALSE
51250 .LESS: JUMPE A,CPOPJ
51260 JSP C,OP
51270 JRST COMP2 ;bignums know about me
51280 JRST COMP2
51290
51300 COMP2: CAML A,TT
51310 JRST FALSE
51320 JRST TRUE
51330
51340 .MAX: MOVEI D,.GREAT
51350 SKIPA
51360 .MIN: MOVEI D,.LESS
51370 MOVE AR1,A
51380 MOVE AR2A,B
51390 PUSHJ P,(D)
51400 SKIPN A
51410 MOVE AR1,AR2A
51420 MOVE A,AR1
51430 POPJ P,
51440 PAGE
51450 MAKNUM: CAIE B,FLONUM(S) ;## DEFAULT TO FIXNUM, NOT FLONUM
51460 JRST FIX1A
51470 FLO1A:
51480 MOVEI B,FLONUM(S)
51490 PUSHJ P,FWCONS
51500 JRST ACONS-1
51510
51520 FIX1B: SUBI A,INUM0
51530 MOVEI B,FIXNUM(S)
51540 PUSHJ P,FWCONS
51550 JRST ACONS-1
51560
51570 NUMVLX: JFCL 17,.+1
51580 NUMVAL: HRRZS A ;** Get rid of any garbage in LH(A)
51590 CAIG A,INUMIN
51600 JRST NUMAG1
51610 SUBI A,INUM0
51620 MOVEI B,INUM(S) ;** Ch. from FIXNUM
51630 POPJ P,
51640
51650 NUMAG1: MOVE REL,A ;** CH FROM AR1
51660 HRRZ A,(A)
51670 HLRZ B,(A)
51680 HRRZ A,(A)
51690 CAIE B,FIXNUM(S)
51700 CAIN B,FLONUM(S)
51710 SKIPA A,(A)
51720 NUMV4: SKIPA A,REL ;** DITTO
51730 POPJ P,
51740 NUMV2: PUSHJ P,EPRINT ;bignums know about me
51750 JRST NONNUM
51760
51770 NUMV3: JRST NONNUM ;bignums change me to JRST BIGDIS
51780 PAGE
51790 FLOATP: JUMPL A,FIXOV ;** ERROR IF 36 BITS TO FLOAT
51800 FLOAT: IDIVI A,400000
51810 SKIPE A
51820 TLC A,254000
51830 TLC B,233000
51840 FADR A,B
51850 POPJ P,
51860
51870 FIX: PUSH P,A
51880 PUSHJ P,NUMVAL
51890 CAIE B,FLONUM(S)
51900 JRST POPAJ
51910 MULI A,400
51920 TSC A,A
51930 JFCL 17,.+1
51940 ASH B,-243(A)
51950 FIX2: JFCL 10,FIXOV ;bignums change me to jfcl 10,bfix
51960 POP P,A
51970 FIX1: MOVE A,B
51980 JRST FIX1A
51990
52000 MINUSP: PUSHJ P,NUMVAL
52010 JUMPGE A,FALSE
52020 JRST TRUE
52030
52040 MINUS: PUSHJ P,NUMVLX
52050 MOVNS A
52060 JFCL 10,@OPOV
52070 JRST MAKNUM
52080
52090 ABS: PUSHJ P,NUMVLX
52100 MOVMS A
52110 JRST MINUS+2
52120
52130 NUMTYP: CAILE A,INUMIN ;[UT] IS IT AN INUM?
52140 JRST NUMTY2
52150 MOVE B,A ;** (SAVE A IN B AND RETURN IT THERE)
52160 PUSHJ P,ATOM1 ;** IS A NON-NIL ATOM?
52170 JUMPE A,CPOPJ ;** NO - NOT A NUMBER
52180 HRRZ A,(B)
52190 HLRZ A,(A)
52200 NUMTY1: CAIE A,FIXNUM(S)
52210 CAIN A,FLONUM(S)
52220 POPJ P,
52230 JRST FALSE
52240 NUMTY2: MOVEI A,INUM(S) ; IT'S AN INUM
52250 POPJ P,
52260
52270 INUMP: CAIG A,INUMIN ;## INUM IF > INUMIN
52280 JRST FALSE ;## NO, RETURN NIL
52290 POPJ P, ;## RETURN USEFUL VALUE
52300 PAGE
52310 DIVIDE: CAIN B,INUM0
52320 JRST ZERODIV
52330 JSP C,OP
52340 JRST RDIV ;bignums know about me
52350 JRST ILLNUM
52360 RDIV: IDIV A,TT
52370 PUSH P,B
52380 PUSHJ P,FIX1A
52390 EXCH A,(P)
52400 PUSHJ P,FIX1A
52410 POP P,B
52420 JRST XCONS
52430
52440 REMAINDER:
52450 PUSHJ P,DIVIDE
52460 JRST CDR
52470
52480 FIXOV: ERR2 [SIXBIT /INTEGER OVERFLOW!/]
52490 ZERODIV:ERR2 [SIXBIT /ZERO DIVISOR!/]
52500 FLOOV: ERR2 [SIXBIT /FLOATING OVERFLOW!/]
52510 ILLNUM: ERR2 [SIXBIT /NON-INTEGRAL OPERAND!/]
52520
52530 GCD: JSP C,OP
52540 JRST GCD2 ;bignums know about me
52550 JRST ILLNUM
52560 GCD2: MOVMS A
52570 MOVMS TT
52580 ;euclid's algorithm
52590 GCD3: CAMG A,TT
52600 EXCH A,TT
52610 JUMPE TT,FIX1A
52620 IDIV A,TT
52630 MOVE A,B
52640 JRST GCD3
52650 PAGE
52660 ;general arithmetic op code routine for mixed types
52670
52680 OP: CAIG A,INUMIN
52690 JRST OPA1
52700 SUBI A,INUM0
52710 CAIG B,INUMIN
52720 JRST OPA2
52730 HRREI TT,-INUM0(B)
52740 XCT (C) ;inum op (cannot cause overflow)
52750 FIX1A: ADDI A,INUM0
52760 CAILE A,INUMIN
52770 CAIL A,-1
52780 JRST FIX1B
52790 POPJ P,
52800
52810 OPA1: HRRZ A,(A)
52820 HLRZ T,(A)
52830 HRRZ A,(A)
52840 CAIE T,FIXNUM(S)
52850 JRST OPA6
52860 SKIPA A,(A)
52870 OPA2:
52880 MOVEI T,FIXNUM(S)
52890 CAILE B,INUMIN
52900 JRST OPB2
52910 HRRZ B,(B)
52920 HRRZ TT,(B)
52930 HLRZ B,(B)
52940 CAIE B,FIXNUM(S)
52950 JRST OPA5
52960 SKIPA TT,(TT)
52970 OPB2: HRREI TT,-INUM0(B)
52980 JFCL 17,.+1
52990 XCT (C) ;fixed pt op
53000 OPOV: JFCL 10,FIXOV ;bignums change this to jfcl 10,fixovl
53010 JRST FIX1A
53020
53030 OPA6: CAILE B,INUMIN
53040 JRST OPB7
53050 HRRZ B,(B)
53060 HRRZ TT,(B)
53070 HLRZ B,(B)
53080 CAIE B,FLONUM(S)
53090 JRST OPB3
53100 CAIE T,FLONUM(S)
53110 JRST NUMV3
53120 MOVE A,(A)
53130 MOVE TT,(TT)
53140 OPR: JFCL 17,.+1
53150 XCT 1(C) ;flt pt op
53160 JFCL 10,FLOOV
53170 JRST FLO1A
53180
53190 OPA5:
53200 CAIE B,FLONUM(S)
53210 JRST NUMV3
53220 PUSHJ P,FLOAT
53230 JRST OPR-1
53240
53250 OPB3:
53260 CAIE B,FIXNUM(S)
53270 JRST NUMV3
53280 SKIPA TT,(TT)
53290 OPB7: HRREI TT,-INUM0(B)
53300 MOVEI B,FIXNUM(S)
53310 CAIE T,FLONUM(S)
53320 JRST NUMV3
53330 MOVE A,(A)
53340 EXCH A,TT
53350 PUSHJ P,FLOAT
53360 EXCH A,TT
53370 JRST OPR
53380 PAGE
53390 SUBTTL EXPLODE, READLIST AND FRIENDS
53400
53410 %FLATSIZEC: SKIPA R,.+1 ;$$ FLATSIZEC - (LENGTH (EXPLODEC))
53420 FLATSIZE: HRRZI R,FLAT2
53430 SETZM FLAT1
53440 PUSHJ P,PRINTA
53450 MOVE A,FLAT1#
53460 JRST FIX1A
53470 FLAT2: AOS FLAT1
53480 POPJ P,
53490
53500 %AEXPLD: SKIPA R,.+1 ;** EXPLODES which return ASCII chars
53510 AEXPLD: HRRZI R,EXPL1 ;**
53520 SETOM AEXFLG# ;** Set flag for ASCII values
53530 JRST EXPLODE+2 ;**
53540
53550 %EXPLODE: SKIPA R,.+1
53560 EXPLODE: HRRZI R,EXPL1
53570 SETZM AEXFLG ;** Set flag for character atoms
53580 MOVSI AR1,AR1
53590 PUSHJ P,PRINTA
53600 JRST SUBS4
53610
53620 EXPL1: PUSH P,B
53630 PUSH P,C
53640 ANDI A,177
53650 ;** (Code to convert digits to inums removed)
53660 SKIPN AEXFLG ;** Check for AEXPLODE(C)
53670 JRST EXPL2 ;** No - convert to atomic symbol
53680 CAIG A,11 ;** Yes - is it ASCII 0-11?
53690 ADDI A,200 ;** If so, offset it for READLIST
53700 ADDI A,INUM0 ;** Convert to INUM ASCII
53710 JRST EXPL4 ;** And use it
53720 EXPL2: PUSH P,AR1
53730 PUSH P,R ;** SAVE R
53740 PUSHJ P,READCH+1 ;** USE READCH TO CREATE ATOM
53750 POP P,R
53760 POP P,AR1
53770 EXPL4: PUSHJ P,NCONS
53780 HLR B,AR1
53790 HRRM A,(B)
53800 HRLM A,AR1
53810 POP P,C
53820 JRST POPBJ
53830 PAGE
53840 READLIST: TDZA T,T
53850 MAKNAM: MOVNI T,1
53860 MOVEM T,NOINFG
53870 ;** (SAVE/RESTORE OF OLDCH DONE IN READ0)
53880 JUMPE A,MAKERR ;** (ch from NOLIST)
53890 HRRM A,MKNAM3
53900 MOVEI A,MKNAM2
53910 PUSHJ P,READ0
53920 HRRZ T,MKNAM3
53930 CAIE T,-1
53940 JUMPN T,MAKERR ;** USERS CHARS LEFT UNREAD
53950 POPJ P,
53960 MKNAM2: PUSH P,B
53970 PUSH P,TT
53980 HRRZ TT,MKNAM3#
53990 JUMPE TT,MKNAM6
54000 CAIN TT,-1
54010 JRST MAKERR ;** NOT A COMPLETE EXPRESSION
54020 HRRZ B,(TT)
54030 HRRM B,MKNAM3
54040 HLRZ A,(TT)
54050 CAIGE A,INUMIN
54060 JRST MKNAM5
54070 SUBI A,INUM0 ;** Number
54080 CAIG A,11 ;** Is it 0-11?
54090 ADDI A,"0" ;** Yes - he wants a digit
54100 ANDI A,177 ;** No - reduce to 7 bit ASCII
54110 MKNAM4: POP P,TT
54120 JRST POPBJ
54130 MKNAM5: HLRZ A,(TT)
54140 PUSH P,C ;** SAVE C AROUND GETPNM
54150 PUSHJ P,GETPNM ;** USE GETPNM TO GET PNAME
54160 POP P,C ;** RESTORE C
54170 HLRZ A,(A)
54180 LDB A,[POINT 7,(A),6]
54190 JRST MKNAM4
54200 MKNAM6: MOVEI A," "
54210 HLLOS MKNAM3
54220 JRST MKNAM4
54230 MAKERR: SETZM OLDCH ;** ERROR - CLEAR OUT ANY GARBAGE
54240 ERR2 [SIXBIT /ILL-FORMED EXPRESSION - MAKNAM!/]
54250 PAGE
54260 SUBTTL EVAL APPLY -- THE INTERPRETER
54270
54280 APPLY.: CAILE A,INUMIN ;$$ AN APPLY TO HANDLE ANY FUNCTION TYPE
54290 JRST UNDTAG
54300 JUMPE A,UNDTAG ;** NIL NOT A FUNCTION
54310 HLRZ T,(A)
54320 CAIE T,-1
54330 JRST AP2 ;** ALL AP2'S CH. FROM 'GAPP'
54340 HRRZ T,(A)
54350 AAGN: JUMPE T,AP2 ;**
54360 HLRZ TT,(T)
54370 HRRZ T,(T)
54380 CAIN TT,FSUBR(S)
54390 JRST [HLRZ T,(T)
54400 JUMPE T,UNDTAG ;** DON'T ALLOW FSUBR PROP. OF NIL
54410 MOVE A,B
54420 JRST (T)]
54430 CAIN TT,FEXPR(S)
54440 JRST [ HLRZ T,(T)
54450 HRL T,A
54460 PUSH P,T
54470 MOVE A,B
54480 JRST APPL.2]
54490 CAIN TT,MACRO(S)
54500 JRST [ PUSHJ P,CONS
54510 HLRZ T,(T) ;** Added to save another eval blip
54520 CALLF 1,(T) ;**
54530 JRST EVAL]
54540 CAIN TT,EXPR(S)
54550 JRST AP2 ;**
54560 CAIN TT,SUBR(S)
54570 JRST AP2 ;**
54580 CAIE TT,LSUBR(S)
54590 JRST AAGN
54600 JRST AP2 ;**
54610
54620 COMMENT %
54630 ;** NO NEED TO DO THIS:
54640 GAPP: HRREI T,-2
54650 PUSH P,A
54660 PUSH P,B
54670 JRST APPLY
54680 %
54690 PAGE
54700 OEVAL: AOJN T,AEVAL ;(THIS IS LISP EVAL)
54710 POP P,A
54720 ;(THIS IS LISP *EVAL)
54730 EVAL: PUSH P,SP ;$$SAVE SPDL (** USED BY GO AND RETURN)
54740 PUSHJ P,XXEVAL ;$$GO DO EVALUATION AS USUAL
54750 POP P,SP ;$$RESTORE SPDL
54760 POPJ P, ;$$AND RETURN TO CALLER
54770
54780 XXEVAL: JUMPE A,CPOPJ ;** FAST EVAL FOR NIL
54790 CAILE A,INUMIN
54800 POPJ P,
54810 HRRZ AR1,A
54820
54830 ;$$CODE TO PUT EVAL BLIP ON SPECIAL PDL
54840
54850 PUSH P,B ;$$SAVE WHAT WAS IN B
54860 HRRZI B,-1(P) ;$$GET RPDL POINTER AND OFFSET
54870 HRLI B,UNBOUND(S) ;$$ SET UP RPDL POINTER
54880 PUSH SP,B ;$$ SAVE RPDL POINTER ON SPDL
54890 PUSH SP,A ;$$SAVE EVAL FORM ON SPDL
54900 POP P,B ;$$AND GO ON
54910 HLRZ T,(A) ;;;;;;;;;;;;;
54920
54930 CAIN T,-1 ;** Check for atoms before ↑H check
54940 JRST EE1 ;x is atomic
54950 JUMPE T,UNDFUN ;** NIL NOT A FUNCTION
54960 CAILE T,INUMIN
54970 JRST UNDFUN
54980 SKIPN ERINT(S) ;$$CHECK IF DDT (CONTROL H) INTERRUPT OCCURRED (** ↑H)
54990 JRST EVNOH ;$$SKIP OVER INTERRUPT FEATURE
55000 PUSH P,A ;** SAVE EXPRESSION
55010 MOVE A,T ;** GET FUNCTION TO BE INTERRUPTED
55020 HRRZ B,UNBRKS(S) ;** GET LIST OF UNBREAKABLE FUNCTIONS
55030 PUSHJ P,MEMB ;** AND SEE IF THIS CAN BE BROKEN
55040 JUMPN A,EVNOH-1 ;** NO - WAIT TILL A BREAKABLE FUNC OCCURS
55050 POP P,A ;** YES - GET EXPRESSION BACK
55060 SETZM ERINT(S) ;$$TURN OFF INTERRUPT FLAG (** ↑H)
55070 PUSHJ P,EPRINT+2 ;$$PRINT OUT WHAT WAS INTERRUPTED
55080 ERR2 [SIXBIT /WAS JUST INTERRUPTED - NOW IN ERRORX!/]
55090 POP P,A ;** GET EXPRESSION BACK
55100 EVNOH: HLRO TT,(T)
55110 AOJE TT,EE2 ;car (x) is atomic
55120 JRST EXP3
55130 EE1:
55140 EV5: HRRZ AR1,(AR1)
55150 JUMPE AR1,UNBVAR
55160 HLRZ TT,(AR1)
55170 CAIE TT,FLONUM(S)
55180 CAIN TT,FIXNUM(S)
55190 POPJ P,
55200 CAIN TT,STRING(S) ;** STRINGS EVAL TO THEMSELVES
55210 POPJ P, ;**
55220 EVBIG: HRRZ AR1,(AR1) ;bignums know about me
55230 CAIE TT,VALUE(S)
55240 JRST EV5
55250 HLRZ AR1,(AR1)
55260 HRRZ AR1,(AR1)
55270 CAIN AR1,UNBOUND(S)
55280 JRST UNBVAR
55290 MOVEM AR1,A
55300 POPJ P,
55310 PAGE
55320 ; HANDLER OF ALISTS AND SPDL CONTEXT POINTERS
55330 ;** SEVERAL CHANGES TO MAKE POINTERS SAME AS SPDL POINTERS
55340
55350 ALIST: MOVEM SP,SPSV
55360 SKIPN A,-1(P) ;** GET ALIST OR SPDL POINTER
55370 JRST ALIST2 ;** NIL - FORGET IT
55380 CAILE A,INUMIN
55390 JRST ASPEC ;** IT'S A POINTER
55400 PUSHJ P,REVERSE ;** IT'S AN ALIST (UGH)
55410 SKIPA ;** NO LONGER UNBINDS ENTIRE SPDL
55420 ALIST1: MOVE A,B ;** JUST BINDS VARS IN ALIST
55430 HRRZ B,(A)
55440 HLRZ A,(A)
55450 HRRZ AR1,(A)
55460 HLRZ A,(A)
55470 PUSHJ P,BIND
55480 JUMPN B,ALIST1
55490 ALIST2: PUSH SP,SPSV
55500 POPJ P,
55510
55520 ASPEC: MOVEI A,-INUM0(A) ;** CONVERT TO ACTUAL STACK POINTER
55530 HLRZ TT,SC2 ;** (WITH VALID LHS)
55540 ADD TT,A
55550 ADD A,SC2
55560 HRL A,TT
55570 MOVE C,SP
55580 ASPEC1: CAMG C,A ;** CHECK IF UNBOUND TO DESIRED POINT
55590 JRST ALIST2 ;done
55600 POP C,T ;pointer for next block
55610 JUMPGE T,ASPEC1 ;$$SKIP ANY EVAL BLIP CRAP
55620 ASPEC2: CAMN C,T
55630 JRST ASPEC1 ;thru with block
55640 POP C,AR1
55650 TLNE AR1,-1 ;$$ TEST FOR EVAL BLIP
55660 JRST .+3
55670 SUB C,[XWD 1,1] ;$$ FOUND ONE, SKIP RPDL WORD
55680 JRST ASPEC2
55690 MOVSS AR1
55700 PUSH SP,(AR1) ;save value cell
55710 HLRM AR1,(AR1) ;store previous value in value cell
55720 HRLM AR1,(SP) ;save pointer to spec pdl loc
55730 JRST ASPEC2
55740
55750 AEVAL: PUSHJ P,ALIST
55760 POP P,A
55770 MOVEI A,UNBIND
55780 EXCH A,(P)
55790 JRST EVAL
55800 PAGE
55810 EE2: HRRZ T,(T)
55820 JUMPE T,EV3
55830 HLRZ TT,(T)
55840 HRRZ T,(T)
55850 CAIN TT,SUBR(S)
55860 JRST ESB
55870 CAIN TT,LSUBR(S)
55880 JRST EELS
55890 CAIN TT,EXPR(S)
55900 JRST AEXP
55910 CAIN TT,FSUBR(S)
55920 JRST EFS
55930 CAIN TT,MACRO(S)
55940 JRST EFM
55950 CAIE TT,FEXPR(S)
55960 JRST EE2
55970
55980 HLRZ T,(T) ;** (FEXPR)
55990 HLL T,(AR1)
56000 PUSH P,T
56010 HRRZ A,(A)
56020 APPL.2: TLO A,400000 ;** (Set bit for spdl arg)
56030 PUSH P,A
56040 MOVNI T,1
56050 JRST IAPPLY
56060
56070 AEXP: HLRZ T,(T) ;** (EXPR)
56080 HLL T,(AR1)
56090 EXP3: PUSH P,T
56100 HRRZ A,(AR1)
56110 CILIST: JSP TT,ILIST
56120 EXP2: JRST IAPPLY
56130
56140 EFS: HLRZ T,(T) ;** (FSUBR)
56150 JUMPE T,UNDFUN ;** DON'T ALLOW FSUBR PROP. OF NIL
56160 HRRZ A,(AR1)
56170 JRST (T)
56180
56190 EV3: HLRZ A,(AR1) ;** (Here if no function property)
56200 MOVEI B,VALUE(S)
56210 PUSHJ P,GET
56220 JUMPE A,UNDFUN ;function object has no definition
56230 HRRZ A,(A)
56240 REMOTE<
56250 XXX4:
56260 UBDPTR: UNBOUND>
56270 HLRZ B,(AR1) ;$$GET ORIGINAL FN NAME
56280 CAME A,B ;$$IF VALUE IS THE SAME THEN WE HAVE A LOOP
56290 CAMN A,UBDPTR
56300 JRST UNDFUN
56310 HRRZ B,(AR1) ;eval (cons (cdr a)(cdr ar1))
56320 PUSHJ P,CONS
56330 JRST XXEVAL
56340
56350 ESB: HRRZ A,(AR1) ;** (SUBR)
56360 UUOS2: HLRZ T,(T)
56370 JUMPE T,UNDFUN ;** DON'T ALLOW SUBR PROP. OF NIL
56380 HLL T,(AR1)
56390 PUSH P,T
56400 JSP TT,ILIST
56410 ESB1: CAMGE T,[-NACS] ;** CHECK FOR TOO MANY ARGS
56420 JRST TOMANY ;**
56430 JSP TT,PDLARG ;** Let PDLARG clear and load regs
56440 POPJ P,
56450
56460 EFM: HLRZ T,(T) ;** (MACRO)
56470 PUSH P,A ;** SAVE MACRO EXPRESSION
56480 CALLF 1,(T)
56490 JUMPE A,POPBJ ;** NIL EXPANSION -> NO SAVING, NO EVAL
56500 HRRZ B,VMACEX(S) ;** CHECK MACROEXPANSION FLAG
56510 JUMPE B,EFM1 ;** NIL - NO SPECIAL EXPANSION SAVING
56520 PUSH P,A ;** T - SAVE EXPANSION
56530 MOVE B,@-1(P) ;** CREATE (MACROEXPANSION new old)
56540 PUSHJ P,CONS+1 ;** NEED TO DUPLICATE FIRST WORD OF EXPR
56550 PUSHJ P,NCONS ;**
56560 POP P,B ;**
56570 PUSHJ P,XCONS ;**
56580 HRLI A,MACEXP(S) ;**
56590 MOVEM A,@0(P) ;** REUSE FIRST WORD OF MACRO EXPRESSION
56600 HLRZ A,0(A) ;** GET EXPANSION BACK
56610 EFM1: POP P,B ;** POP OFF SAVED EXPRESSION
56620 JRST EVAL ;** AND GO EVALUATE EXPANSION
56630
56640 DOMACX: HLRZ A,0(A) ;** DEFN OF MACROEXPANSION FSUBR
56650 JRST EVAL ;** JUST EVALUATE 1ST ARG (THE EXPANSION)
56660 PAGE
56670
56680 APPLY: MOVEI TT,AP2 ;(THIS IS LISP APPLY)
56690 CAME T,[-3]
56700 JRST PDLARG
56710 MOVEM T,APFNG1#
56720 PUSHJ P,ALIST
56730 MOVE T,APFNG1
56740 JSP TT,PDLARG
56750 PUSH P,[UNBIND]
56760 AP2: PUSH P,A ;(THIS IS LISP *APPLY)
56770 MOVEI T,0
56780 AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list
56790 HLRZ C,(B)
56800 PUSH P,C ;push arg
56810 HRRZ B,(B)
56820 SOJA T,AP3
56830
56840 IAPPLY: MOVE C,T ;state of world at entrance
56850 ADDI C,(P) ;t has - number of args on pdl
56860 ILP1A: HRRZ B,(C) ;next pdl slot has function- poss fun name in lh
56870 JUMPE B,UNDTAC ;** NIL NOT A FUNCTION
56880 CAILE B,INUMIN
56890 JRST UNDTAC
56900 HLRZ A,(B)
56910 CAIN A,-1
56920 JRST IAP1 ;fn is atomic
56930 CAIN A,LAMBDA(S)
56940 JRST IAPLMB
56950 CAIN A,FUNARG(S)
56960 JRST APFNG
56970 CAIN A,LABEL(S)
56980 JRST APLBL
56990 PUSH P,T
57000 MOVE A,B
57010 PUSHJ P,EVAL
57020 POP P,T
57030 MOVE C,T
57040 ADDI C,(P)
57050 ILP1B: MOVEM A,(C)
57060 JRST ILP1A
57070 PAGE
57080 IAPXPR: HLRZ A,(B)
57090 JRST ILP1B
57100 IAP1: HRRZ B,(B) ;** (Atomic function)
57110 JUMPE B,IAP2
57120 HLRZ TT,(B)
57130 HRRZ B,(B)
57140 CAIN TT,EXPR(S)
57150 JRST IAPXPR
57160 CAIN TT,LSUBR(S)
57170 JRST IAP6
57180 CAIE TT,SUBR(S)
57190 JRST IAP1
57200 HLRZ B,(B)
57210 JUMPE B,UNDTAC ;** DON'T ALLOW SUBR PROP. OF NIL
57220 MOVEM B,(C)
57230 JRST ESB1
57240 PAGE
57250 FUNCT: HLRZ B,(A) ;** (*FUNCTION)
57260 HRRZ A,SP
57270 ADD A,SPNM ;** MAKE IT A SPDL POINTER
57280 PUSHJ P,XCONS
57290 MOVEI B,FUNARG(S)
57300 JRST XCONS
57310
57320 APFNG: SOS T ;** (FUNARG)
57330 MOVEM T,APFNG1
57340 JSP TT,PDLARG ;get args and funarg list
57350 HRRZ A,(A)
57360 HRRZ D,(A) ;a-list pointer
57370 HLRZ A,(A) ;function
57380 HRLZ R,APFNG1 ;no. of args
57390 PUSH P,[UNBIND]
57400 JSP TT,ARGP1 ;replace args and fn name
57410 PUSH P,D ;a-list pointer
57420 PUSHJ P,ALIST ;set up spec pdl
57430 POP P,D
57440 AOS T,APFNG1
57450 JRST IAPPLY
57460
57470 IAPLMB: HRRZ B,(B) ;** (LAMBDA)
57480 HLRZ TT,(B)
57490 MOVEM SP,SPSV
57500 HRRZ B,(B)
57510 HLRZ D,(TT)
57520 CAIN D,-1
57530 JUMPN TT, IAP3
57540 MOVE R,T
57550 IPLMB1: JUMPE TT,IPLMB2 ;** NO MORE PARAMETERS
57560 JUMPN T,IAP5 ;** MORE ARGS TO BIND
57570 JUMPGE D,.+4 ;** NO MORE ARGS - FEXPR?
57580 HRRZ A,SP ;** YES - EXTRA ARG FOR ALIST FEATURE
57590 ADD A,SPNM ;** MAKE IT A SPDL POINTER
57600 SKIPA ;**
57610 MOVEI A,NIL ;** USE NIL FOR OTHER MISSING ARGS
57620 PUSH P,A ;** PUSH ARG
57630 SOS T ;** AND FIX SO IT LOOKS LIKE IT WAS
57640 SOS R ;** THERE IN THE FIRST PLACE
57650 IAP5: HLRZ A,(TT)
57660 MOVEI AR1,1(T)
57670 ADD AR1,P
57680 HLLZ D,(AR1)
57690 HRLM A,(AR1)
57700 HRRZ TT,(TT)
57710 AOJA T,IPLMB1
57720
57730 IPLMB2: JUMPN T,TOMANY ;** too many args supplied
57740 JUMPE R,IAP69
57750 IPLMB4: POP P,AR1
57760 HLRZ A,AR1
57770 AOJG R,IPLMB3
57780 PUSHJ P,BIND
57790 JRST IPLMB4
57800 IPLMB3:
57810 IFN ALVINE<
57820 SKIPE BACTRF ;** ONLY IF ALVINING
57830 JRST APBK1>
57840 APBK2: MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
57850 PUSH SP,SPSV
57860 MOVE T,B ;$$SETUP FOR IMPLIED PROG
57870 PUSHJ P,COND2+1 ;$$INSTEAD OF EVAL
57880 JRST UNBIND
57890
57900 IAP69: POP P,(P)
57910 MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
57920 MOVE T,B ;$$
57930 JRST COND2+1 ;$$INSTEAD OF EVAL
57940
57950 IFN ALVINE<
57960 APBK1: HRRI AR1,CPOPJ ;** ONLY IF ALVINING
57970 TLNE AR1,-1
57980 PUSH P,AR1
57990 JRST APBK2>
58000 IAP6: HLRZ B,(B)
58010 JUMPE B,UNDTAC ;** DON'T ALLOW LSUBR PROP. OF NIL
58020 MOVEI TT,CPOPJ
58030 MOVEM TT,(C)
58040 JRST (B)
58050
58060 APLBL: MOVEM SP,SPSV ;** (LABEL)
58070 HRRZ B,(B)
58080 HLRZ A,(B)
58090 HRRZ B,(B)
58100 HLRZ AR1,(B)
58110 MOVEM AR1,(C)
58120 PUSHJ P,BIND
58130 MOVEI A,APLBL1
58140 EXCH A,-1(C)
58150 EXCH A,LBLAD#
58160 HRLI A,LBLAD
58170 PUSH SP,A
58180 PUSH SP,SPSV
58190 JRST IAPPLY
58200 APLBL1: PUSH P,LBLAD
58210 JRST SPECSTR
58220
58230 IAP2: HRRZ A,(C)
58240 MOVEI B,VALUE(S)
58250 PUSHJ P,GET
58260 JUMPE A,UNDTAC
58270 HRRZ A,(A)
58280 HRRZ B,(C) ;$$GET ORIGINAL FN NAME
58290 CAME A,B ;$$IF THE VALUE IS THE SAME THEN WE HAVE A LOOP
58300 CAIN A,UNBOUND(S)
58310 JRST UNDTAC
58320 JRST ILP1B
58330
58340 IAP3: MOVNI AR1,-INUM0(T) ;lexpr call
58350 MOVE A,TT
58360 PUSHJ P,BIND
58370 PUSH P,%ARG
58380 SUBI C,INUM0
58390 HRRM C,%ARG
58400 PUSH SP,SPSV
58410 MOVEI A,NIL ;$$ MORE FOR IMPLIED PROG
58420 MOVE T,B ;$$
58430 PUSHJ P,COND2+1 ;$$ INSTEAD OF EVAL
58440 HRRZ T,%ARG
58450 POP P,%ARG
58460 SUBI T,1-INUM0(P)
58470 HRLI T,-1(T)
58480 ADD P,T
58490 JRST UNBIND
58500
58510 ARG: HRRZ A,@%ARG
58520 POPJ P,
58530
58540 REMOTE<
58550 %ARG: XWD A,0>
58560 SETARG: HRRZM B,@%ARG
58570 JRST PROG2
58580 PAGE
58590 BIND: JUMPE A,BNDERR ;$$CAN'T REBIND NIL
58600 CAIN A,TRUTH(S) ;$$SHOULDN'T REBIND T
58610 JRST BNDERR ;$$
58620 PUSH P,B
58630 PUSHJ P,LITATOM ;** CAN'T BIND NON-LITATOM
58640 EXCH A,B ;** (LITATOM LEAVES A IN B)
58650 JUMPE B,BNDERR ;**
58660 HRRZM A,BIND3#
58670 BIND2:
58680 MOVEI B,VALUE(S) ;bind atom in a to value in ar1,save
58690 PUSHJ P,GET ;old binding on s pdl
58700 JUMPE A,BIND1 ;add value cell
58710 PUSH SP,(A)
58720 HRLM A,(SP)
58730
58740 HRRM AR1,(A) ;$$THIS WAS HHRZM AR1,(A) WHICH CLOBBERED ATOM POINTER IN MY SYSTEM
58750 SETZM BIND3 ;** SO GC WON'T MARK GARBAGE
58760 POPBJ: POP P,B
58770 POPJ P,
58780
58790 BIND1:
58800 MOVEI B,UNBOUND(S)
58810
58820 MOVE A,BIND3 ;$$SET UP ATOM POINTER FROM SPECIAL CELL
58830 ;$$THIS WAS MOVEI A,0
58840 PUSHJ P,CONS
58850 HRRZ B,@BIND3
58860 PUSHJ P,CONS
58870 MOVEI B,VALUE(S)
58880 PUSHJ P,XCONS
58890 HRRM A,@BIND3
58900 MOVE A,BIND3
58910 JRST BIND2
58920
58930 UBD: CAMG SP,B
58940 POPJ P,
58950
58960 HLRZ TT,(SP) ;$$SKIP OVER EVAL BLIPS ETC.
58970 JUMPN TT,.+3 ;$$IF EQUAL TO 0 IT WAS AN EVAL BLIP
58980 SUB SP,[XWD 2,2] ;$$DECREMENT SPDL
58990 JRST UBD ;$$GO BACK AND CHECK
59000 PUSHJ P,UNBIND
59010 JRST UBD
59020
59030 UNBIND:
59040 SPECSTR: MOVE TT,(SP)
59050 CAMN SP,SC2 ;$$CHECK TO AVOID OVERSHOOT
59060 POPJ P, ;$$
59070
59080 SUB SP,[XWD 1,1]
59090 JUMPGE TT,UNBIND ;syncronize stack
59100 UNBND1: CAMN SP,TT
59110 POPJ P,
59120 POP SP,T
59130
59140
59150 CAIN T,(T) ;$$CHECK TO SKIP OVER NEW ITEMS PUT ON SPDL
59160 ;$$ALL SUCH ITEMS HAVE 0 LEFT HAND SIDES
59170 JRST PROGUB ;$$THIS IS AN EVAL BLIP - CHECK IF A PROG
59180
59190 MOVSS T
59200
59210 HLRM T,(T) ;$$CHANGED FROM HLRZM T,(T) TO PROTECT NEW ATOM POINTER
59220
59230 JRST UNBND1
59240
59250
59260 PROGUB: HLRZ T,(T) ;$$CHECK FOR A PROG
59270 CAIE T,PROGAT(S) ;$$CHECK IF IT IS A PROG
59280 JRST PROGU1 ;$$NOT A PROG, SKIP IT AND GO ON
59290 MOVE T,(SP) ;$$GET THE RPDL POINTER FOR PROG INTO T
59300 ADDI T,2 ;$$INCREMENT TO GET TO WHERE PA3,PA4 SAVED
59310 POP T,PA4 ;$$RESTORE PA4
59320 POP T,PA3 ;$$AND PA3 FROM WHERE THEY WERE SAVED
59330 PROGU1: POP SP,T ;$$ POP RPDL POINTER
59340 JRST UNBND1 ;$$AND GO ON WITH THE UNBINDING
59350
59360
59370
59380 SPECBIND: MOVE TT,SP
59390 SPEC1: LDB R,[POINT 13,(T),ACFLD]
59400 CAILE R,17
59410 JRST SPECX
59420 SKIPE R
59430 MOVE R,(R)
59440 HLL R,@(T) ;$$AGAIN SAVE THE POOR LITTLE ATOM POINTER
59450 EXCH R,@(T)
59460 HRLI R,@(T)
59470 PUSH SP,R
59480 AOJA T,SPEC1
59490 SPECX: PUSH SP,TT
59500 JRST (T)
59510
59520 ;random special case compiler run time routines
59530
59540 %AMAKE: HRRZ B,SP ;make alist for fsubr that requires it
59550 ADD B,SPNM ;** MAKE IT A SPDL POINTER
59560 POPJ P,
59570
59580 %UDT: PUSHJ P,EPRNT1 ;error print for undefined computed go tag
59590 STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
59600 HRRZ R,(P)
59610 PUSHJ P,ERSUB3
59620 SETOM ERRTYP ;** SET "SERIOUS" ERROR
59630 JRST ERREND
59640
59650 %LCALL: MOVN A,T ;set up routine for compiled lsubr
59660 ADDI A,INUM0
59670 ADDI T,(P)
59680 PUSH P,T
59690 PUSHJ P,(3)
59700 POP P,T
59710 SUBI T,(P)
59720 HRLI T,-1(T)
59730 ADD P,T
59740 POPJ P,
59750 PAGE
59760 SUBTTL ARRAY SUBROUTINES
59770
59780 ;** MODIFIED TO HANDLE CASE WHERE BPS EXTENDS BEYOND 177777
59790 ARRAY: PUSHJ P,ARRAYS
59800 HRRI AR2A,1(R)
59810 MOVE A,AR2A ; CUMULATED SIZE
59820 PUSH R,[0] ; FILL THEM ALL WITH NIL'S
59830 AOBJN A,.-1
59840 ARREND: MOVE A,BPPNR#
59850 MOVEM AR2A,-1(A)
59860 MOVEI A,1(R)
59870 PUSHJ P,FIX1A ;*** FIXED TO HANDLE NON-INUMS
59880 EXCH A,VBPORG(S) ;*** RETURN ADDRESS OF ARRAY
59890 POPJ P,
59900
59910 ARRAYS: PUSH P,A
59920 MOVE A,VBPORG(S)
59930 PUSHJ P,NUMVAL ;*** FIXED TO HANDLE NON-INUMS
59940 MOVEM A,BPPNR
59950 MOVE A,VBPEND(S)
59960 PUSHJ P,NUMVAL ;*** DITTO
59970 MOVNI A,-2(A)
59980 ADD A,BPPNR ;bporg-bpend+2
59990 HRLM A,BPPNR ;= BPORG-BPEND+2,,BPORG
60000 POP P,A
60010 HRRZ AR1,(A) ;(cdr l)
60020 HLRZ A,(A) ;(car l)name
60030 HRRZ B,BPPNR
60040 ADDI B,2
60050 MOVEI C,SUBR(S)
60060 PUSHJ P,PUTPROP ;(PUTPROP<NAME><BPORG>SUBR)
60070 HLRZ A,(AR1) ;(cadr l)mode
60080 PUSH P,AR1
60090 PUSHJ P,EVAL ;eval mode
60100 POP P,AR1
60110 MOVEM A,AMODE# ; STORE MODE AWAY
60120 MOVEI C,44 ; C IS BITS/ELEMENT
60130 JUMPE A,ARRY1 ; NIL=REAL NUMBERS MODE
60140 MOVEI C,-INUM0(A)
60150 CAILE A,INUMIN
60160 JRST ARRY1 ; NUMERIC MODE
60170 MOVEI C,22 ; NON-NUMERIC = T = S-EXPRS 2/WORD
60180 HRRZ A,BPPNR
60190 MOVE B,GCMKL
60200 PUSHJ P,CONS ; CONS BPORG ONTO GCMKL
60210 MOVEM A,GCMKL
60220 ARRY1: MOVEM C,BSIZE# ; NUMBER OF BITS/ELEMENT
60230 MOVEI A,44
60240 IDIV A,C
60250 MOVEM A,NBYTES# ; NUMBER OF ELEMENTS/WORD
60260 HRRZ A,(AR1) ;(cddr l)bound pair list
60270 JSP TT,ILIST ; PUTS REVERSE OF SIZES ONTO STACK,T=-# OF DIMS.
60280 AOS R,BPPNR ; R=BPORG-BPEND+2,,BPORG+1
60290 MOVEI AR1,1 ;ar1 is array size
60300 MOVEI AR2A,0 ;ar2a is cumulative residue
60310 AOJGE T,ARRYS ;single dimension
60320 MOVEI D,A-1
60330 SUB D,T ;d is next ARGUMENT ac for array code generation
60340 ARRY2: PUSHJ P,ARRB0 ;BUILDS IMULI (D),OFFSET/ ADD(D),(D)+1
60350 TLC TT,(IMULI)
60360 DPB D,[POINT 4,TT,ACFLD]
60370 PUSH R,TT
60380 CAIN D,A
60390 JRST ARRY3
60400 MOVSI TT,(ADD)
60410 ADDI TT,1(D)
60420 DPB D,[POINT 4,TT,ACFLD]
60430 PUSH R,TT
60440 SOJA D,ARRY2
60450
60460 ARRB0: POP P,TT ; REMOVE ELEMENT ON STACK BELOW EXIT
60470 EXCH TT,(P)
60480 CAILE TT,INUMIN ; IS IT A NUMBER
60490 JRST ARRB1 ; YES
60500 HLRZ A,(TT) ; NO, A DOTTED PAIR
60510 HRRZ TT,(TT)
60520 ; SUBI TT,(A)
60530 ; ADDI TT,1
60540 ; JRST ARRB2
60550 ; SKIPA TT,1(TT) ;[UT] (** Hmmm....)
60555 AOJA TT,ARRB1+1 ;** (Try this instead)
60560
60570 ARRB1: MOVEI A,INUM0
60580 ; SUB TT,A
60590 SUBI TT,(A) ;[UT]
60600 ;[UT] TT HAS THE LENGTH, A IS THE LOWER BOUND AS AN INUM
60610 IMUL A,AR1 ;[UT] WAS ARRB2:
60620 IMULB AR1,TT
60630 ;%% ADDM A,AR2A
60640 ADD AR2A,A ;%% SOME PEOPLE HAVE PROBLEMS
60650 POPJ P,
60660
60670 ARRY3: PUSH R,[ADD A,B]
60680 ARRYS: PUSHJ P,ARRB0
60690 HRRZ TT,BPPNR
60700 MOVEM AR2A,(TT)
60710 HRLI TT,(SUB A,)
60720 PUSH R,TT
60730 PUSH R,[JUMPL A,ARRERR]
60740 MOVE TT,AR1
60750 HRLI TT,(CAIL A,)
60760 PUSH R,TT
60770 PUSH R,[JRST ARRERR]
60780 IDIV AR1,NBYTES ;calc #words in array
60790 SKIPE AR2A ;correct for remainder non-zero
60800 ADDI AR1,1
60810 MOVE TT,NBYTES
60820 SOJE TT,ARRY6
60830 ADDI TT,1
60840 HRLI TT,(IDIVI A,)
60850 PUSH R,TT
60860 MOVN TT,BSIZE
60870 LSH TT,14
60880 HRLI TT,(IMULI B,)
60890 PUSH R,TT
60900 MOVEI TT,44+200
60910 SUB TT,BSIZE
60920 LSH TT,6
60930 ARRY6: ADD TT,BSIZE
60940 LSH TT,6
60950 SKIPE AR2A,AMODE
60960 CAIL AR2A,INUMIN
60970 ADDI TT,40 ;mode not = t
60980 TLC TT,(HRLZI C,)
60990 PUSH R,TT
61000 MOVEI TT,4(R)
61010 HRLI TT,(ADDI C,(A))
61020 PUSH R,TT
61030 PUSH R,[LDB A,C]
61040 HRLZI AR2A,(POPJ P,)
61050 SKIPN TT,AMODE
61060 MOVE AR2A,[JRST FLO1A]
61070 CAIL TT,INUMIN
61080 MOVE AR2A,[JRST FIX1A]
61090 PUSH R,AR2A
61100 MOVS AR2A,AR1
61110 MOVNS AR2A
61120 POPJ P,
61130 PAGE
61140 ;** MODIFIED TO HANDLE CASE WHEN BPS EXTENDS BEYOND 177777
61150 GTBLK: PUSH P,B ;** SAVE GC FLAG
61160 MOVNI C,-INUM0(A) ;##COMPUTE NEGATIVE LENGTH
61170 MOVE A,VBPORG(S) ;## GET BPORG
61180 PUSHJ P,NUMVAL ;## CONVERT (** FIXED FOR NON-INUMS)
61190 HRLM C,(A) ;## MOVE TO BPORG INFO FOR (GC)
61200 HRRM A,(A) ;##
61210 PUSH P,A ;** SAVE ADDR OF BLOCK
61220 AOS R,(A) ;## ADD ONE TO INFO AND MOVE TO R
61230 SUBI R,1 ;## SET PUSH DOWN POINTER(ASSUME POINTER BLOCK)
61240 SKIPN -1(P) ;## IS IT A POINTER BLOCK? (**)
61250 SUBI R,1 ;## NO
61260 MOVE A,VBPEND(S) ;## GET BPEND
61270 PUSHJ P,NUMVAL ;## CONVERT (** FIXED FOR NON-INUMS)
61280 MOVNS A ;** CONVERT TO NEGATIVE
61290 ADD A,R ;## BPORG-BPEND +(0 OR 1) (**)
61300 HRLI R,(A) ;## MOVE TO R FOR TESTING FOR BPS EXCEEDED
61310 PUSH R,[0] ;## CLEAR THE SPACE, NOTE THAT IF IT IS NOT
61320 AOJN C,.-1 ;## WE WILL ALSO CLEAR THE INFO LOCATION
61330 HRRZI A,1(R) ;## COMPUTE NEW BPORG (**)
61340 PUSHJ P,FIX1A ;** FIXED FOR NON-INUMS
61350 HRRM A,VBPORG(S)
61360 POP P,A ;** GET ADDRESS OF BLOCK
61370 POP P,B ;** GET GC FLAG
61380 CAIN B,0 ;## IF IT WAS NOT A POINTER BLOCK, DONE
61390 POPJ P,
61400 MOVE B,GCMKL ;## GET GC'S LIST
61410 PUSHJ P,CONS ;## CONS
61420 MOVEM A,GCMKL ;## SAVE IT
61430 HLRZ A,(A) ;GET THE OLD BPORG BACK
61440 AOJA A,.-5 ;## ADD ONE AND RETURN
61450
61460
61470 BLKLST: PUSH P,A ;## SAVE LIST
61480 CAIE B,0 ;## BLK LENGTH GIVEN
61490 SKIPA A,B ;## YES
61500 PUSHJ P,LENGTH ;## NO, USE LENGTH OF LIST
61510 MOVEI B,(A) ;## GET A POINTER BLOCK FROM GTBLK
61520 PUSHJ P,GTBLK
61530 POP P,B ;## GET LIST BACK
61540 PUSH P,A
61550 HRRZI R,-1(A) ;## SET UP PDL
61560 HLRE C,(R) ;## NEG LENGTH FROM GC INFO.
61570 BLKLS1: HRRI A,1(A) ;## BUMP A FOR CDR
61580
61590 IFN OLDNIL< ;## IF(CDR NIL)#NIL
61600 TRNE B,-1 ;## END OF LIST?
61610 SKIPA B,(B) ;## NO
61620 SETZ B, ;## YES, REST OF BLOCK IS NIL
61630 >
61640
61650 IFE OLDNIL<
61660 MOVE B,(B) ;## IF (CDR NIL )=NIL
61670 >
61680
61690 HLL A,B ;## GET (CAR LIST)
61700 PUSH R,A ;## AND STORE
61710 AOJL C,BLKLS1 ;## SEE IF DONE
61720 HLLZM A,(R) ;## SET (CDR (LAST BLOCK)) TO NIL
61730 JRST POPAJ ;## AND RETURN POINTER TO THE BLOCK
61740
61750
61760 EXARRAY: PUSH P,A
61770 HLRZ A,(A)
61780 PUSHJ P,GETSYM
61790 JUMPE A,POPAJ
61800 PUSHJ P,NUMVAL
61810 EXCH A,(P)
61820 PUSHJ P,ARRAYS
61830 POP P,A
61840 HRRM A,-2(R)
61850 HRR AR2A,A
61860 JRST ARREND
61870
61880 STORE: PUSH P,A
61890 PUSHJ P,CADR
61900 PUSHJ P,EVAL ;value to store
61910 EXCH A,(P)
61920 HLRZ A,(A)
61930 PUSHJ P,EVAL ;byte pointer returned in c
61940 POP P,A
61950 NSTR: PUSH P,A
61960 TLNE C,40
61970 PUSHJ P,NUMVAL ;numerical array
61980 DPB A,C
61990 POPAJ: POP P,A
62000 POPJ P,
62010
62020 PAGE
62030 SUBTTL EXAMINE, DEPOSIT , ETC
62040
62050 BOOLE: MOVE TT,T
62060 ADDI TT,2(P)
62070 MOVE A,-1(TT)
62080 SUBI A,INUM0
62090 DPB A,[POINT 4,BOOLI,OPFLD-2]
62100 PUSHJ P,BOOLG
62110 MOVE C,A
62120 BOOLL: PUSHJ P,BOOLG
62130 XCT BOOLI
62140 REMOTE<
62150 BOOLI: CLEARB C,A>
62160 JRST BOOLL
62170
62180 BOOLG: CAIL TT,(P)
62190 JRST BOOL1
62200 MOVE A,(TT)
62210 PUSHJ P,NUMVAL
62220 AOJA TT,CPOPJ
62230
62240 BOOL1: HRLI T,-1(T)
62250 ADD P,T
62260 POP P,B
62270 JRST FIX1A
62280
62290 EXAMINE: PUSHJ P,NUMVAL
62300 MOVE A,(A)
62310 JRST FIX1A
62320
62330 DEPOSIT: MOVE C,B
62340 PUSHJ P,NUMVAL
62350 EXCH A,C
62360 PUSHJ P,NUMVAL
62370 MOVEM A,(C)
62380 JRST MAKNUM
62390
62400 LSH: MOVEI C,-INUM0(B)
62410 PUSHJ P,NUMVAL
62420 LSH A,(C)
62430 JRST FIX1A
62440
62450 PAGE
62460 SUBTTL GARBAGE COLLECTER
62470
62480 ;garbage collector
62490
62500 GC: MOVEI R,1 ;** COPY NIL INTO ACS 1-10 SO GARBAGE
62510 BLT R,10 ;** WON'T BE MARKED
62520 PUSHJ P,AGC
62530 JRST FALSE
62540
62550 AGC: SETOM GCFLAG ;SET GCFLAG INCASE OF USER CONTROL-C
62560 MOVEM R,RGC#
62570 GCPK1: PUSH P,PA3
62580 PUSH P,PA4
62590 IFE OLDNIL <PUSH P,NILHD ;** FAKE ATOM HEADER OF NIL>
62600 PUSH P,UBDPTR ;special atom UNBOUND; not on OBLIST
62610 PUSH P,MKNAM3
62620 PUSH P,GCMKL ;i/o channel input lists and arrays
62630 PUSH P,BIND3
62640 PUSH P,INITF
62650 PUSH P,INITF1 ;## INIT FILE LIST
62660 GCPK2: PUSH P,[XWD 0,GCP6] ;this is a return address
62670 JRST GCP4
62680 REMOTE<
62690 GCP4: MOVEI S,X ;pdlac, .=bottom of reg pdl + 1
62700 GCP41: BLT S,X ;save ACs 0 through 10 at bottom of regpdl ;pdlac+n
62710 GCP2: CLEARB 0,X ;gc indicator, init. for bit table zero
62720 MOVE A,C3GC
62730 GCP5: BLT A,X ;zero bit tables, .=top of bit tables
62740 JRST GCRET1>
62750 GCRET1: SKIPN GCGAGV
62760 JRST GCP5A
62770 SKIPN F
62780 STRTIP [SIXBIT /←FREE STG EXHAUSTED←!/]
62790 SKIPN FF
62800 STRTIP [SIXBIT /←FULL WORD SPACE EXHAUSTED←!/]
62810
62820 GCP5A: MOVEI TT,1
62830 MOVEI A,0
62840 CALLI A,RUNTIM ;time
62850 MOVNS A
62860 ADDM A,GCTIM#
62870 MOVE C,GCP3# ;.=bottom of reg pdl
62880 GCP6B: MOVE S,P
62890 HLL C,P
62900 MOVEI B,0
62910 GC1: CAMN C,S
62920 POPJ P,
62930 HRRZ A,(C)
62940 GCPI: CAMGE A,GCP# ;.=bottom of bit tables
62950 REMOTE<
62960 GCPP1:
62970 XXX5: FS>
62980 CAMGE A,GCPP1
62990 JRST GCEND
63000 CAML A,GCP1# ;.=bottom of full word space (fws)
63010 JRST GCMFW
63020 MOVE F,(A)
63030 LSHC A,-5
63040 ROT B,5
63050 MOVE AR1,GCBT(B)
63060 TDOE AR1,@GCBTP2 ;bit tab- (fs←-5), .=magic number for sync
63070 JRST GCEND
63080 MOVEM AR1,@GCBTP1 ;bit tab- (fs←-5)
63090 PUSH P,F
63100 HLRZ A,F
63110 JRST GCPI
63120 REMOTE<
63130 GCBTP1: XWD A,0
63140 GCBTP2: XWD A,0
63150 GCMFWS: XWD A,0>
63160
63170 GCMFW: MOVEI AR1,@GCMFWS ;.=- bottom of fws
63180 IDIVI AR1,44
63190 MOVNS AR2A
63200 LSH AR2A,36
63210 ADD AR2A,C2GC
63220 DPB TT,AR2A
63230 GCEND: CAMN P,S
63240 AOJA C,GC1
63250 POP P,A
63260 HRRZS A
63270 JRST GCPI
63280 REMOTE<
63290 GCMKL: XWD 0,[XWD [XWD -NIOCH,CHTAB+FSTCH],0]
63300 C2GC: XWD 430100+AR1,X ;.=bottom of fws bit table
63310 C3GC: 0> ;(bottom bit table)bottom bit table+1
63320 GCBT: XWD 400000,0
63330 ZZ==1B1
63340 XLIST
63350 REPEAT ↑D31,<ZZ
63360 ZZ==ZZ/2>
63370 LIST
63380 GCP6: HRRZ R,SC2
63390 GCP6C: CAILE R,(SP) ;mark sp (**Ch. from CAIL 4/24/77)
63400 JRST GCP6A
63410 PUSH P,(R)
63420 HRRZ C,P
63430 PUSHJ P,GCP6B
63440 SUB P,[XWD 1,1]
63450 AOJA R,GCP6C
63460
63470 GCP6A: HRRZ R,GCMKL ;mark arrays
63480 GCP6D: JUMPE R,GCSWP
63490 HLRZ A,(R)
63500 MOVE D,(A)
63510 GCP6E: PUSH P,(D)
63520 HRRZ C,P
63530 PUSH P,(D)
63540 MOVSS (P)
63550 PUSHJ P,GCP6B
63560 SUB P,[XWD 2,2]
63570 AOBJN D,GCP6E
63580 HRRZ R,(R)
63590 JRST GCP6D
63600
63610 GFSWPP:
63620 PHASE 0
63630 GFSP1==.
63640 JUMPL S,.+3
63650 HRRZM F,(R)
63660 HRRZ F,R
63670 ROT S,1
63680 AOBJN R,.-4
63690 MOVE S,(D)
63700 HRLI R,-40
63710 AOBJN D,GFSP1
63720
63730 LPROG==.
63740 JRST GFSPR
63750
63760 DEPHASE
63770 ;garbage collector sweep
63780
63790 GCSWP: MOVSI R,GFSWPP
63800 BLT R,LPROG
63810 MOVEI F,NIL ;will become movei f,-1
63820 MOVE D,C3GCS
63830 JRST XXX3
63840 REMOTE<
63850 XXX3: MOVEI R,FS ;$$ANOTHER FOOLIST REMNANT
63860 GCBTL1: HRLI R,X ;-(32-<fs&37>
63870 MOVE S,(D)
63880 GCBTL2: ROT S,X ;fs&37
63890 AOBJN D,GFSP1
63900 JRST GFSPR>
63910 GFSPR: MOVE A,C1GCS
63920 MOVE B,C2GCS
63930 PUSHJ P,GCS0
63940 SKIPN GCGAGV
63950 JRST GCSPI1
63960 MOVE S,ATMOV ;** Restore S for GC print
63970 MOVE B,F
63980 PUSHJ P,GCPNT
63990 STRTIP [SIXBIT / FREE STG, !/]
64000 MOVE B,FF
64010 PUSHJ P,GCPNT
64020 STRTIP [SIXBIT / FULL WORDS AVAILABLE←!/]
64030 GCSPI1: HRLZ S,GCSP1# ;bottom of reg pdl+1
64040 BLT S,NACS+3 ;reload ac's
64050 SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1] ;restore p
64060 MOVE R,RGC
64070 MOVEI A,0
64080 CALLI A,RUNTIM ;time
64090 ADDM A,GCTIM
64100 MOVE S,ATMOV ;$$RESTORE ATOM OFFSET RELOCATOR (FOOLIST)
64110 ;$$HOPEFULLY S IS USED ONLY BY GC AND ATOM RELOCATION
64120 SKIPE CCFLAG ;** ↑C HIT WHILE GCING?
64130 PUSHJ P,GCINT ;** YES: GO INTERRUPT
64140 SETZM GCFLAG ;CLEAR GCFLAG
64150 JUMPE F,[ERR3 [SIXBIT /NO FREE STG LEFT!/]]
64160 JUMPE FF,[ERR3 [SIXBIT /NO FW STG LEFT!/]]
64170 POPJ P,
64180
64190 GCINT: POP P,CCFLAG ;** ↑C - GET CONTINUE ADDR
64200 SETZM GCFLAG ;** CLEAR GCFLAG
64210 JRST CCINT1 ;** AND ENTER ↑C TRAP ROUTINE
64220
64230 GCS0: MOVEI FF,0
64240 GCS1: ILDB C,B
64250 JUMPN C,GCS2
64260 HRRZM FF,(A)
64270 HRRZ FF,A
64280 GCS2: AOBJN A,GCS1
64290 POPJ P,
64300
64310 REMOTE<
64320 C1GCS: 0 ;(- length of fws) bottom of fws
64330 C2GCS: XWD 100,0 ;.=bottom of fws bit table
64340 C3GCS: 0 ;-n wds in bt,,bt
64350 >
64360 GCGAG: EXCH A,GCGAGV#
64370 POPJ P,
64380
64390 GCTIME: MOVE A,GCTIM
64400 JRST FIX1A
64410
64420 TIME: MOVEI A,0
64430 CALLI A,RUNTIM
64440 JRST FIX1A
64450
64460 DTIME: CALLI A,MSTIME ;** TIME OF DAY
64470 JRST FIX1A
64480
64490 DODATE: CALLI A,DATE ;** DATE IN FORM (MO DAY YEAR-1900)
64500 IDIVI A,↑D31
64510 MOVEI T,INUM0+1(B) ;day
64520 IDIVI A,↑D12
64530 MOVEI TT,INUM0+1(B) ;month
64540 ADDI A,INUM0+↑D64 ;year-1900
64550 PUSHJ P,NCONS
64560 MOVE B,T
64570 PUSHJ P,XCONS
64580 MOVE B,TT
64590 JRST XCONS
64600
64610 SPEAK: MOVE A,CONSVAL#
64620 JRST FIX1A
64630
64640 GCPNT: MOVEI R,TTYO
64650 MOVEI A,0
64660 JUMPE B,PRINIC+1 ;** PRINT USING CURRENT BASE
64670 HRRZ B,(B)
64680 AOJA A,.-2
64690
64700 IFN REALLC <
64710 ;%% NEW ROUTINES TO COUNT AVAILABLE
64720 ;%% FREE SPACE AND FULL WORD SPACE
64730
64740 FSCNT: TDZA C,C ;%% INITIALIZE
64750 FWCNT: MOVEI C,1 ;%%
64760 MOVE B,F(C) ;%% FREE LIST START
64770 SETZ A, ;%% COUNTER
64780 JUMPE B,FIX1A ;%% WHEN DONE, NO MORE POINTER
64790 HRRZ B,(B) ;%%
64800 AOJA A,.-2 ;%%
64810 >
64820 PAGE
64830 SUBTTL SYMBOL TABLE ACCESSING ROUTINES
64840
64850
64860 R50MAK: PUSHJ P,PNAMUK
64870 PUSH C,[0]
64880 HRLI C,700
64890 HRRI C,(SP)
64900 MOVEI B,0
64910 MK3: ILDB A,C
64920 LDB A,R50FLD
64930 CAMGE B,[50*50*50*50*50]
64940 SKIPN A
64950 POPJ P,
64960 IMULI B,50
64970 ADD B,A
64980 JRST MK3
64990
65000 ;## NEW ROUTINES FOR CONVERTING SYMBOLS TO CONS CELL
65010
65020 SYMERR: MOVE A,B
65030 SYMER1: PUSHJ P,EPRINT ;## PRINT OFFENDER
65040 ERR2 [SIXBIT /NOT A CONS CELL !/]
65050 ;## **CAUSES ERROR IF NOT IN FREE STORAGE**
65060 RGTSYM: PUSHJ P,GETSYM
65070 JUMPE A,CPOPJ ;** FORGET IT IF NOT THERE
65080 PUSHJ P,NUMVAL ;## CONVERT TO REAL ADDRESS
65090 ADDI A,(S) ;## ADD RELOCATION
65100 CAIL A,FS(S) ;## LESS THAN FS(S) IS NOT CONS CELL
65110 CAML A,FWSO ;## FS(S)<= A < FWSO IS A CONS CELL
65120 JRST SYMER1
65130 JRST FIX1A ;** CONVERT BACK TO A NUMBER
65140
65150 GETSYM: PUSHJ P,R50MAK
65160 TLO B,040000 ;04 for globals
65170 MOVE C,.JBSYM
65180 MK7: CAMN B,(C)
65190 JRST MK10 ;found
65200 AOBJP C,.+2
65210 AOBJN C,MK7
65220 TLC B,140000 ;10 for locals
65230 TLNE B,100000
65240 JRST MK7-1
65250 JRST FALSE
65260
65270 MK10: MOVE A,1(C) ;value
65280 JRST FIX1A
65290
65300
65310 ;## ROUTINE TO STORE A CONS CELL SO THAT IT CAN BE
65320 ;## REFERENCED VIA ,CELL(S) I.E. THRU INDEX REG. S
65330 ;## ERROR IF NOT LEGITIMATE CONS CELL
65340 RPTSYM: CAIL B,FS(S) ;## FS(S) =< B <FWSO IS A LEGIT
65350 CAML B,FWSO ;## CONS CELL, ALL ELSE IS ERROR
65360 JRST SYMERR ;## ERROR
65370 SUBI B,(S) ;## STRIP OFF RELOCATION
65380
65390 PUTSYM: PUSH P,B
65400 PUSHJ P,R50MAK
65410 MOVE A,B
65420 TLO A,040000 ;make global
65430 SKIPL .JBSYM
65440 AOS .JBSYM ;increment initial symbol table pointer
65450 MOVN B,[XWD 2,2]
65460 ADDB B,.JBSYM
65470 MOVEM A,(B) ;name
65480 POP P,1(B) ;value
65490 JRST FALSE
65500
65510 PAGE
65520 SUBTTL SPRINT -- THE PRETTY PRINTER
65530 IFE SPRNT <XLIST> ;** (SPRINT REPLACED BY COMPILED CODE)
65540 IFN SPRNT,<
65550
65560
65570 ;THIS IS THE NEW IMPROVED VERSION OF SPRINT
65580
65590 ; 0(P) = A
65600 ; -1(P) = B
65610 ; -2(P) = C
65620 ; -3(P) = M
65630 ; -4(P) = N
65640 ; -5(P) = X
65650
65660
65670 SPRINT: SUBI B,INUM0
65680 SPRNT2: PUSH P,A
65690 PUSH P,B
65700 SETZM M#
65710 SETZM CSW#
65720 MOVEM P,STP#
65730 MOVEI B,0
65740 PUSHJ P,DEPTH
65750 SKIPN B,M
65760 JRST .+6
65770 MOVE A,LINL
65780 SUB A,B
65790 SUB A,B
65800 IDIV A,B
65810 CAILE A,14
65820 MOVEI A,14
65830 MOVEM A,CUT#
65840 MOVE A,0(P)
65850 IDIV A,LINL
65860 CAIG B,0
65870 ADD B,LINL
65880 MOVEM B,0(P)
65890 MOVEI C,0
65900 JRST .+3
65910
65920 ISPRIN: PUSH P,A
65930 PUSH P,B
65940 PUSH P,C
65950 PUSH P,[0]
65960 PUSH P,[0]
65970 PUSH P,[0]
65980 MOVE A,B
65990 SUB B,LINL
66000 JUMPLE B,.+3
66010 MOVE A,B
66020 MOVEM A,-4(P)
66030 PUSHJ P,POS
66040 MOVE A,-5(P)
66050 PUSHJ P,PATOM
66060 JUMPE A,.+4
66070 SPRN1: MOVE A,-5(P)
66080 PUSHJ P,PRIN1
66090 JRST SPRN22
66100 MOVE B,LINL
66110 SUB B,-4(P)
66120 ADDI B,1
66130 MOVEM B,0(P)
66140 SUB B,-3(P)
66150 MOVE A,-5(P)
66160 PUSHJ P,FLATLE
66170 JUMPN A,SPRN1
66180 MOVEI A,50
66190 PUSHJ P,TYO
66200 AOS -4(P)
66210 SOS 0(P)
66220 HRRZ A,@-5(P)
66230 PUSHJ P,PATOM
66240 JUMPN A,SPRN13
66250 HLRZ A,@-5(P)
66260 CAIN A,LAMBDA(S)
66270 JRST LAM
66280 CAIN A,PROGAT+1(S)
66290 JRST PRG
66300 PUSHJ P,PATOM
66310 JUMPE A,SPRN3
66320 HLRZ A,@-5(P)
66330 PUSHJ P,PRIN1
66340 MOVE A,0(P)
66350 SUB A,CHCT
66360 MOVEM A,-1(P)
66370 CAIG A,24
66380 JRST SPRN4
66390 JRST SPRN12+4
66400 SPRN3: MOVE B,0(P)
66410 CAILE B,20
66420 MOVEI B,20
66430 HLRZ A,@-5(P)
66440 PUSHJ P,FLATLE
66450 JUMPE A,SPRN12
66460 MOVEM A,-1(P)
66470 SPRN4: HRRZ A,@-5(P)
66480 MOVEM A,-2(P)
66490 HRRZ A,0(A)
66500 PUSHJ P,PATOM
66510 JUMPN A,SPRN8
66520 MOVE B,-1(P)
66530 CAMG B,CUT
66540 JRST SPRN2
66550 SKIPE CSW
66560 JRST SPRN8
66570 MOVE A,0(P)
66580 SUB A,B
66590 SUBI A,1
66600 MOVEM A,-1(P)
66610 JRST SPRN5
66620 SPRN2: HLRZ A,@-5(P)
66630 PUSHJ P,PATOM
66640 JUMPN A,.+3
66650 HLRZ A,@-5(P)
66660 PUSHJ P,PRIN1
66670 HRRZ A,@-5(P)
66680 MOVEM A,-5(P)
66690 MOVE A,-4(P)
66700 ADD A,-1(P)
66710 ADDI A,1
66720 MOVEM A,-4(P)
66730 JRST SPRN12
66740 SPRN5: MOVE B,-1(P)
66750 HLRZ A,@-2(P)
66760 PUSHJ P,FLATLE
66770 JUMPE A,SPRN8
66780 HRRZ A,@-2(P)
66790 MOVEM A,-2(P)
66800 HRRZ A,0(A)
66810 PUSHJ P,PATOM
66820 JUMPE A,SPRN5
66830 HRRZ B,@-2(P)
66840 JUMPN B,.+3
66850 MOVE B,-1(P)
66860 SOJA B,SPRN7
66870 HRRZ A,@-2(P)
66880 PUSHJ P,FLATSI
66890 SUBI A,INUM0-4
66900 SUB A,-1(P)
66910 MOVN B,A
66920 SPRN7: SUB B,-3(P)
66930 HLRZ A,@-2(P)
66940 PUSHJ P,FLATLE
66950 JUMPN A,SPRN18
66960 SPRN8: HLRZ A,@-5(P)
66970 PUSHJ P,PATOM
66980 JUMPN A,.+3
66990 SPRN9: HLRZ A,@-5(P)
67000 PUSHJ P,PRIN1
67010 HRRZ A,@-5(P)
67020 MOVEM A,-5(P)
67030 CAMN A,-2(P)
67040 JRST SPRN11
67050 MOVE A,-4(P)
67060 PUSHJ P,POS
67070 JRST SPRN9
67080 SPRN11: HRRZ A,@-5(P)
67090 PUSHJ P,PATOM
67100 JUMPN A,SPRN13
67110 SPRN12: MOVEI C,0
67120 MOVE B,-4(P)
67130 HLRZ A,@-5(P)
67140 PUSHJ P,ISPRIN
67150 HRRZ A,@-5(P)
67160 MOVEM A,-5(P)
67170 JRST SPRN11
67180 SPRN13: HRRZ A,@-5(P)
67190 JUMPE A,.+4
67200 PUSHJ P,FLATSI
67210 SUBI A,INUM0-3
67220 ADDM A,-3(P)
67230 AOS -3(P)
67240 MOVE C,-3(P)
67250 MOVE B,-4(P)
67260 HLRZ A,@-5(P)
67270 PUSHJ P,ISPRIN
67280 SPRN16: HRRZ A,@-5(P)
67290 JUMPE A,SPRN17
67300 MOVEI A,40
67310 PUSHJ P,TYO
67320 MOVEI A,56
67330 PUSHJ P,TYO
67340 MOVEI A,40
67350 PUSHJ P,TYO
67360 HRRZ A,@-5(P)
67370 PUSHJ P,PRIN1
67380 SPRN17: MOVEI A,51
67390 PUSHJ P,TYO
67400 JRST SPRN22
67410 SPRN18: HLRZ A,@-5(P)
67420 PUSHJ P,PATOM
67430 JUMPN A,.+3
67440 HLRZ A,@-5(P)
67450 PUSHJ P,PRIN1
67460 MOVEI A,40
67470 PUSHJ P,TYO
67480 HRRZ A,@-5(P)
67490 MOVEM A,-5(P)
67500 MOVE A,LINL
67510 SUB A,CHCT
67520 ADDI A,1
67530 MOVEM A,-4(P)
67540 HRRZ A,@-5(P)
67550 PUSHJ P,PATOM
67560 JUMPN A,SPRN21
67570 SPRN19: HLRZ A,@-5(P)
67580 PUSHJ P,PRIN1
67590 HRRZ A,@-5(P)
67600 MOVEM A,-5(P)
67610 HRRZ A,0(A)
67620 PUSHJ P,PATOM
67630 JUMPN A,.+4
67640 MOVE A,-4(P)
67650 PUSHJ P,POS
67660 JRST SPRN19
67670 MOVE A,-4(P)
67680 PUSHJ P,POS
67690 SPRN21: HLRZ A,@-5(P)
67700 PUSHJ P,PRIN1
67710 JRST SPRN16
67720 LAM: PUSHJ P,PRIN1
67730 HRRZ A,@-5(P)
67740 MOVEM A,-5(P)
67750 MOVE B,-4(P)
67760 MOVEM B,-1(P)
67770 HLRZ A,0(A)
67780 PUSHJ P,PATOM
67790 MOVEI B,6
67800 CAIE A,NIL
67810 ADDI B,1
67820 ADDM B,-4(P)
67830 HRRZ A,@-5(P)
67840 PUSHJ P,PATOM
67850 JUMPN A,SPRN13
67860 MOVEI C,0
67870 MOVE B,-4(P)
67880 HLRZ A,@-5(P)
67890 PUSHJ P,ISPRIN
67900 MOVE B,-1(P)
67910 MOVEM B,-4(P)
67920 JRST SPRN12+4
67930 PRG: PUSHJ P,PRIN1
67940 HRRZ A,@-5(P)
67950 MOVEM A,-5(P)
67960 MOVE A,-4(P)
67970 MOVEM A,-1(P)
67980 MOVEI A,5
67990 ADDM A,-4(P)
68000 HRRZ A,@-5(P)
68010 PUSHJ P,PATOM
68020 JUMPN A,SPRN13
68030 MOVEI C,0
68040 MOVE B,-4(P)
68050 HLRZ A,@-5(P)
68060 PUSHJ P,ISPRIN
68070 MOVE A,0(P)
68080 SUBI A,5
68090 MOVEM A,-2(P)
68100 PRG1: HRRZ A,@-5(P)
68110 MOVEM A,-5(P)
68120 HRRZ A,0(A)
68130 PUSHJ P,PATOM
68140 JUMPN A,PRG3
68150 HLRZ A,@-5(P)
68160 PUSHJ P,PATOM
68170 JUMPE A,PRG2
68180 MOVE A,-1(P)
68190 PUSHJ P,POS
68200 HLRZ A,@-5(P)
68210 PUSHJ P,PRIN1
68220 JRST PRG1
68230 PRG2: MOVE A,CHCT
68240 CAMG A,-2(P)
68250 PUSHJ P,TERPRI
68260 MOVEI C,0
68270 MOVE B,-4(P)
68280 HLRZ A,@-5(P)
68290 PUSHJ P,ISPRIN
68300 JRST PRG1
68310 PRG3: HLRZ A,@-5(P)
68320 PUSHJ P,PATOM
68330 JUMPE A,SPRN13
68340 MOVE B,-1(P)
68350 MOVEM B,-4(P)
68360 JRST SPRN13
68370 SPRN22: MOVEI A,NIL
68380 SUB P,[XWD 6,6]
68390 POPJ P,
68400 > ;**
68410 IFE SPRNT <LIST>
68420
68430 POS: PUSH P,A ;** THIS PART OF SPRINT USED BY TAB
68440 PUSH P,[0]
68450 PUSHJ P,CHRPOS ;** USE CHRPOS TO MAKE SURE CHCT CORRECT
68460 SUBI A,INUM0 ;**
68470 PUSH P,A
68480 CAMN A,-2(P)
68490 JRST POS4
68500 CAMG A,-2(P)
68510 JRST .+4
68520 PUSHJ P,TERPRI
68530 MOVEI A,1
68540 MOVEM A,0(P)
68550 SUBI A,1
68560 LSH A,-3
68570 ADDI A,1
68580 LSH A,3
68590 ADDI A,1
68600 MOVEM A,-1(P)
68610 CAMLE A,-2(P)
68620 JRST POS3
68630 POS2: MOVEI A,TAB
68640 PUSHJ P,TYO
68650 MOVE A,-1(P)
68660 MOVEM A,0(P)
68670 ADDI A,10
68680 JRST POS2-3
68690 POS3: AOS A,0(P)
68700 CAMLE A,-2(P)
68710 JRST POS4
68720 MOVEI A,40
68730 PUSHJ P,TYO
68740 JRST POS3
68750 POS4: SUB P,[XWD 3,3]
68760 POPJ P,
68770
68780 IFE SPRNT <XLIST> ;** SOME MORE OLD SPRINT CODE
68790 IFN SPRNT,< ;**
68800 FLATLE: JUMPLE B,ABORT+1
68810 SETZM M
68820 MOVEM B,N#
68830 MOVEM P,STP
68840 SCAN: PUSH P,A
68850 PUSHJ P,PATOM
68860 JUMPN A,EXIT1-6
68870 NA: AOS A,M
68880 CAMLE A,N
68890 JRST ABORT
68900 HLRZ A,@0(P)
68910 PUSHJ P,SCAN
68920 HRRZ A,@0(P)
68930 MOVEM A,0(P)
68940 JUMPN A,.+3
68950 AOS A,M
68960 JRST EXIT1-2
68970 MOVE A,0(P)
68980 PUSHJ P,PATOM
68990 JUMPE A,NA
69000 MOVEI A,4
69010 ADDB A,M
69020 CAMLE A,N
69030 JRST ABORT
69040 MOVE A,0(P)
69050 PUSHJ P,FLATSI
69060 SUBI A,INUM0
69070 ADDB A,M
69080 CAMLE A,N
69090 JRST ABORT
69100 EXIT1: SUB P,[XWD 1,1]
69110 POPJ P,
69120 ABORT: MOVE P,STP
69130 MOVEI A,NIL
69140 POPJ P,
69150
69160 DEPTH: PUSH P,A
69170 PUSH P,B
69180 PUSHJ P,PATOM
69190 JUMPN A,D2
69200 AOS A,0(P)
69210 CAMLE A,LINL
69220 JRST OUT+1
69230 CAMLE A,M
69240 MOVEM A,M
69250 MOVE A,-1(P)
69260 PUSH P,A
69270 PUSH P,[0]
69280 D1: HLRZ A,@-3(P)
69290 MOVE B,-2(P)
69300 PUSHJ P,DEPTH
69310 HRRZ A,@-3(P)
69320 MOVEM A,-3(P)
69330 MOVE B,-1(P)
69340 SETCMB C,0(P)
69350 JUMPN C,.+3
69360 HRRZ B,0(B)
69370 MOVEM B,-1(P)
69380 CAMN A,B
69390 JRST OUT
69400 PUSHJ P,PATOM
69410 JUMPE A,D1
69420 SUB P,[XWD 2,2]
69430 D2: SUB P,[XWD 2,2]
69440 POPJ P,
69450 OUT: SETOM CSW
69460 MOVE P,STP
69470 JRST @1(P)
69480 > ;**
69490 IFE SPRNT <LIST>
69500 ;
69510 ;
69520 ;(TAB X) TABS TO POSITION X DOING A (TERPRI) IF NECESSARY
69530 ;
69540 .TAB: PUSHJ P,NUMVAL
69550 PUSHJ P,POS ;LET POS IN SPRINT DO THE WORK
69560 JRST FALSE
69570
69580 PAGE
69590 SUBTTL ALVINE AND LOADER INTERFACES
69600
69610 IFE ALVINE <XLIST> ;** OLD ALVINE INTERFACE
69620 ;interface to alvine
69630
69640 IFN ALVINE,<
69650 ED: MOVE 10,EDA
69660 JRST (10)
69670 PUSH P,A
69680 HRRZ A,CORUSE
69690 HRRM A,LST
69700 AOS A
69710 HRRM A,EDA#
69720
69730
69740 HRRM A,ED1 ;$$SAVE REENTRY TO EDITOR
69750 AOS ED1# ;$$
69760
69770 MOVSI A,(SIXBIT /ED/)
69780 SETZ D, ;THAT RELOCATION AGAIN - SEE BELOW
69790 PUSHJ P,SYSINI
69800 HRLM A,LST
69810 MOVNS A
69820 PUSHJ P,MORCOR
69830 PUSHJ P,SYSINP+1
69840 POP P,A
69850 JRST ED
69860 GRINDEF:PUSH P,A
69870 PUSHJ P,ED
69880 POP P,A
69890 JRST 2(10)>
69900 IFE ALVINE <LIST>
69910
69920 EXCISE: PUSHJ P,TTYRET ;** Close any open I/O channels
69930 MOVE A,JRELO
69940 CALLI A,CORE
69950 JRST .+1
69960 PUSHJ P,IOBRST ;** (LDFLG now cleared in IOBRST)
69970 IFN ALVINE<
69980 MOVEI A,ED+2
69990 HRRM A,EDA>
70000 JRST TRUE
70010
70020 PAGE
70030
70040 ; lisp loader interface
70050 ;** MODIFIED TO HANDLE CASE WHERE BPS EXTENDS BEYOND 177777
70060 LOAD: MOVEM A,LDPAR#
70070 AOS A,CORUSE
70080 MOVEM A,OLDCU#
70090 SKIPN LDPAR
70100 JRST LOAD2
70110 MOVE A,VBPORG(S)
70120 PUSHJ P,NUMVAL ;** FIXED FOR NON-INUM ADDRESSES
70130 LOAD2: MOVEM A,RVAL# ;final destination of loaded code
70140 MOVSI A,(SIXBIT /LOD/)
70150 SETZ D,
70160 PUSHJ P,SYSINI
70170 SUBI A,150 ;extra room for locations 0 to 137 and slop
70180 PUSH P,A
70190 MOVNS A ;length(loader)
70200 HRRZM A,LODSIZ#
70210 PUSHJ P,MORCOR ;expand core for loader
70220 MOVEM A,LOWLSP# ;location of blt'ed low lisp
70230 MOVN B,(P) ;length(loader)
70240 ADD B,A
70250 MOVEM B,HVAL# ;temporary destination of loaded code
70260 HRLI A,0
70270 MOVE D,A ;THIS IS THE RELOCATION, THE LOADER WILL SAVE IT
70280 BLT A,(B) ;blt up low lisp
70290 MOVEI A,CCBLKL(D) ;**
70300 HRRM A,.JBINT ;** SET NEW ↑C TRAP BLOCK
70310 HLL A,NAME+3(D) ;-length(loader)
70320 HRRI A,137-1
70330 PUSHJ P,SYSINP
70340 SKIPE LDFLG(D)
70350 JRST LOAD3
70360 SETOM LDFLG(D)
70370 MOVSI A,(SIXBIT /SYM/)
70380 PUSHJ P,SYSINI
70390 MOVNS A ;length symbols
70400 PUSHJ P,MORCOR ;expand core for symbols
70410 SKIPGE B,.JBSYM
70420 SOS B ;if no symbol table, use original .JBsym
70430 HLRZ A,NAME+3(D) ;-length(symbols)
70440 ADDB A,B
70450 HLL A,NAME+3(D) ;symbol table iowd
70460 PUSHJ P,SYSINP
70470 HRRM B,.JBSYM
70480 HLLZ A,NAME+3(D)
70490 ADDM A,.JBSYM
70500 SKIPA
70510 LOAD3: SOS .JBSYM ;want .JBsym to point one below 1st symbol
70520 MOVE 3,HVAL(D) ;h
70530 MOVE 5,RVAL(D) ;r
70540 MOVE 2,3
70550 SUB 2,5 ;x=h-r
70560 HRLI 5,12 ;(w)
70570 HRLI 2,11 ;(v)
70580 SETZB 1,4
70590 JSP 0,140 ;call the loader
70600 MOVEM 5,RLAST#(D) ;last location loaded(in final area)
70610 MOVE A,.JBSYM
70620 MOVEM A,.JBSYM(D)
70630 MOVE A,.JBREL
70640 MOVEM A,.JBREL(D) ;update .JBrel
70650 HRLZ 0,LOWLSP(D)
70660 SOS LODSIZ(D)
70670 AOBJN 0,.+1
70680 BLT 0,@LODSIZ(D) ;blt down low lisp
70690 MOVE 0,@LOWLSP ;EVERY THING IS FIXED, DON'T NEED REG. D ANYMORE
70700 HRRZ D,RLAST
70710 MOVE C,RVAL
70720 HRL C,HVAL
70730 SKIPE LDPAR
70740 JRST BINLD
70750 MOVE B,RLAST ;new coruse
70760 LDRET2: BLT C,(D) ;blt down loaded code
70770 HRRZM B,CORUSE ;top of code loaded
70780 MOVEI D,1
70790 ANDCAM D,.JBSYM
70800 SUB B,.JBSYM ;length of free core
70810 ORCMI B,776000
70820 AOJGE B,STRT ;no contraction
70830 ADD B,.JBREL ;new top of core
70840 PUSHJ P,MOVDWN
70850 LDRET3: CALLI B,CORE ;contract core
70860 JRST .+1
70870 JRST STRT
70880
70890 BINLD: MOVE A,VBPEND(S)
70900 PUSHJ P,NUMVAL ;** FIXED FOR NON-INUM ADDRESSES
70910 CAML D,A
70920 JRST [ SETOM BPSFLG ;bps exceeded
70930 SETZM LDFLG ;** Set that symbols lost
70940 SOS B,OLDCU ;** and restore old core bound
70950 JRST LDRET3]
70960 MOVE A,D
70970 PUSHJ P,FIX1A ;** FIXED FOR NON-INUM ADDRESSES
70980 MOVEM A,VBPORG(S) ;updat bporg
70990 SOS B,OLDCU ;old top of core
71000 JRST LDRET2
71010
71020 CCLINT: HRRZ D,.JBINT ;** ↑C HIT DURING LOAD
71030 SUBI D,CCBLKL ;** COMPUTE OFFSET SINCE NOT RESTORED
71040 HRLZ 0,LOWLSP(D)
71050 SOS LODSIZ(D)
71060 SETZM CCBLKL+2(D)
71070 AOBJN 0,.+1
71080 BLT 0,@LODSIZ(D) ;** NOTE THIS RESTORES NORMAL .JBINT
71090 MOVE 0,@LOWLSP
71100 SETZM LDFLG ;** SET THAT SYMBOLS WERE LOST
71110 SOS A,OLDCU ;** Restore old core bound
71120 CALLI A,CORE
71130 JRST .+1
71140 ;** Warn user that LOAD is being killed
71150 OUTSTR [ASCIZ /
71160 Exiting from LOAD . . .
71170 /]
71180 JRST CCSTRT ;** And go process interrupt
71190
71200 REMOTE<
71210 CCBLKL: XWD 4,CCLINT ;** LOADER ↑C INTERRUPT BLOCK
71220 XWD 0,2
71230 0
71240 X>
71250 PAGE
71260
71270 SYSINI: MOVEM A,NAME+1(D)
71280 ;%% FOLLOWING IS OLD, NON-PATCHABLE CHANNEL OPEN
71290 COMMENT &
71300 IFN SYSPRG,< MOVE A,[XWD SYSPRG,SYSPN]
71310 MOVEM A,NAME+3(D)>
71320 IFE SYSPRG,< SETZM NAME+3(D)>
71330 INIT 17
71340 SYSDEV
71350 0
71360 JRST AIN.4+1
71370 & ;%% END OF OLD CODE
71380
71390 ;%% NEW PATCHABLE CODE (DEVICE NAME IN LOW SEGMENT)
71400 MOVE A,SYSIN1(D) ;%% PICK UP PPN
71410 REMOTE<
71420 SYSIN1: XWD SYSPRG,SYSPN ;%% KEEP IN LOW SEGMENT
71430 >
71440 MOVEM A,NAME+3(D) ;%% RESET VALUE HERE
71450 MOVEI A,17 ;%% SET DATA MODE
71460 MOVEM A,SYSIN0(D) ;%%
71470 OPEN 0,SYSIN0(D) ;%% OPEN CHANNEL 0 TO READ FILE
71480 JRST AIN.4+1 ;%% ERROR IN OPEN IF HERE
71490 REMOTE<
71500 SYSIN0: 17 ;%% DUMP MODE I/O
71510 SYSDEV ;%% MAY BE PATCHED
71520 ;%% NOTE THAT THIS MAY REMAIN "SYS"
71530 ;%% WHEN HGHDAT IS CHANGED TO
71540 ;%% SOMETHING ELSE
71550 0 ;%% NO BUFFERING
71560 >
71570 LOOKUP NAME(D)
71580 JRST AIN.7 ;** (Ch. from AIN.7+1)
71590 MOVE A,[IOWD 1,NAME+3] ;KLUDGE BECAUSE OF REG. D
71600 ADD A,D
71610 MOVEM A,INLOW(D)
71620 INPUT INLOW(D) ;INPUT SIZE OF FILE
71630 REMOTE<
71640 INLOW: IOWD 1,NAME+3
71650 0>
71660 HLRO A,NAME+3(D)
71670 POPJ P,
71680
71690 REMOTE<
71700 NAME: SYSNAM
71710 0
71720 0
71730 0>
71740
71750 SYSINP: MOVEM A,LST(D)
71760 INPUT LST(D)
71770 STATZ 740000
71780 ERR2 AIN.8
71790 RELEASE
71800 POPJ P,
71810
71820 REMOTE<
71830 LST: 0
71840 0>
71850 PAGE
71860 MOVDWN: HRLM B,.JBSA ;##SAVE NEW .JBSA
71870 HLRZ A,.JBSYM
71880 JUMPE A,MOVS1
71890 ADDI A,1(B)
71900 HRL A,.JBSYM
71910 HRRM A,.JBSYM
71920 BLT A,(B) ;downward blt
71930 POPJ P,
71940
71950 MOVSYM: MOVE B,.JBREL
71960 HRLM B,.JBSA
71970 HLRE A,.JBSYM
71980 JUMPE A,MOVS1
71990 ADDI B,1(A) ;new bottom of symbol table
72000 MOVNI A,1(A)
72010 ADD A,.JBSYM ;last loc of old symbol table
72020 HRRM B,.JBSYM
72030 PUSH P,C
72040 MOVE B,.JBREL ;last loc of new symbol table
72050 MOVE C,(A) ;simulated upward blt
72060 MOVEM C,(B)
72070 SUBI B,1
72080 ADDI A,-1 ;lf+1,rt-1
72090 JUMPL A,.-4
72100 POP P,C
72110 POPJ P,
72120
72130 MOVS1: HRRZM B,.JBSYM
72140 POPJ P,
72150
72160 ;enter with size needed in a
72170 ;exit with pointer in a to core
72180
72190 MORCOR: PUSH P,B
72200 HRRZ B,.JBSYM
72210 SUB B,CORUSE(D)
72220 SUBM A,B ;NEEDED-(.JBSYM-CORUSE) (IE. NEEDED-FREE)
72230 JUMPL B,EXPND2
72240 ADD B,.JBREL ;new core size
72250 CALLI B,CORE ;expand core
72260 ERR2 [SIXBIT /CANT EXPAND CORE !/]
72270 PUSH P,A
72280 PUSHJ P,MOVSYM
72290 POP P,A
72300 EXPND2: MOVE B,CORUSE(D)
72310 ADDM A,CORUSE(D)
72320 MOVE A,B
72330 POP P,B
72340 POPJ P,
72350 PAGE
72360 SUBTTL HIGH SEGMENT FUNCTIONS
72370
72380 HGHCOR: JUMPE A,NOWRT ;EXPAND CORE AND SET WRITE STATUS
72390 PUSHJ P,NUMVAL
72400 JUMPLE A,FALSE
72410 SETZ C,
72420 CALLI C,SETUWP
72430 UWPERR: ERR2 [SIXBIT /CAN'T CHANGE HIGH SEG. WRITE PROTECT!/]
72440 SETZM WRTSTS ;** MOVED TO AFTER SETUWP CHECK
72450 MOVE B,VHGHORG
72460 ADD B,A
72470 HRRZ C,.JBHRL
72480 CAMG B,C
72490 JRST TRUE
72500 HRLZ A,B
72510 CALLI A,CORE
72520 ERR2 [SIXBIT /CAN'T EXPAND HIGH SEGMENT!/]
72530 JRST TRUE
72540 NOWRT: MOVEI A,1
72550 MOVEM A,WRTSTS
72560 CALLI A,SETUWP
72570 JRST UWPERR
72580 JRST TRUE
72590
72600 HGHORG: SKIPE A ;SET HIGH ORG. TO A AND RETURN OLD ORG.
72610 PUSHJ P,NUMVAL
72620 PUSH P,A
72630 MOVE A,VHGHORG
72640 PUSHJ P,FIX1A ;**
72650 POP P,B
72660 SKIPE B
72670 MOVEM B,VHGHORG
72680 POPJ P,
72690
72700 HGHEND: HRRZ A,.JBHRL ;GET VALUE OF END OF HIGH SEG.
72710 JRST FIX1A ;**
72720
72730 ;SETS THE GETSEG INFO. SO USER CAN HAVE OWN HIGH SEG.
72740 SETSYS: MOVE T,A ;MOVE ARGUMENT FOR UIOSUB
72750 SETZM DEV ;## ALLOW DEFAULT TO DSK:
72760 PUSHJ P,IOSUB ;BREAKS DOWN THE SPECIFICATION
72770 MOVEM A,HGHDAT+1 ;SAVE THE FILE NAME
72780 MOVE A,DEV ;GET THE DEVICE AND SAVE IT
72790 MOVEM A,HGHDAT
72800 MOVE A,PPN ;GET THE PPN AND SAVE IT
72810 MOVEM A,HGHDAT+4
72820 JRST FALSE ;RETURN NIL
72830 REMOTE<
72840 WRTSTS: 1
72850 VHGHORG: BHORG>
72860 PAGE
72870 SUBTTL REALLOC CODE
72880
72890
72900 IFN REALLC <
72910 ;%% DYNAMIC REALLOCTION ROUTINE
72920 ;%%
72930 ;%% ARGUMENTS:
72940 ;%% A = FULL WORD SPACE INCREMENT
72950 ;%% B = BINARY PROGRAM SPACE INCREMENT
72960 ;%% C = REGULAR PUSHDOWN LIST INCREMENT
72970 ;%% AR1 = SPECIAL PUSHDOWN LIST INCREMENT
72980 ;%% AR2A = FREE SPACE INCREMENT
72990 ;%%
73000 ;%% ACTION:
73010 ;%% 1) PERFORMS AN EXCISE
73020 ;%% 2) ALLOCATES ADDITIONAL CORE AS REQUIRED
73030 ;%% (IF IMPOSSIBLE, SIGNALS "CAN'T EXPAND CORE")
73040 ;%% 5) UNBINDS ALL VARIABLES ON THE SPECIAL STACK
73050 ;%% AND CLEARS BOTH STACKS
73060 ;%% 4) REALLOCATES SPACE ACCORDING TO SPECIFICATIONS
73070 ;%% (NOTE THAT TOTAL CORE USED WILL BE ROUNDED
73080 ;%% UP TO A MULTIPLE OF 1K WORDS, AND ANY EXCESS
73090 ;%% WILL BE APPORTIONED TO FWS, RPDL, SPDL, AND
73100 ;%% FS.)
73110 ;%% 5) RESTARTS THE SYSTEM AT THE TOP LEVEL
73120 ;%%
73130
73140 REALL1: JUMPE A,.+2 ;%%NO CONVERSION IF NIL
73150 PUSHJ P,NUMVAL ;%%CONVERT TO BINARY
73160 ADDI T,(A) ;%%ADD TO TOTAL BEING ACCUMULATED
73170 EXCH A,(P) ;%%PUSH ON STACK
73180 JRST (A) ;%%AND RETURN
73190
73200 REALLOC:
73210 SETZ T, ;%% CLEAR ACCUMULATOR FOR ALLOC TOTAL
73220 MOVE TT,B ;%% SAVE SECOND ARG DURING FIRST CALL
73230 PUSHJ P,REALL1 ;%% PROCESS FIRST ARG
73240 MOVE A,TT ;%%
73250 PUSHJ P,REALL1 ;%% PROCESS SECOND ARG
73260 MOVE A,C ;%%
73270 PUSHJ P,REALL1 ;%% PROCESS THIRD ARG
73280 MOVE A,AR1 ;%%
73290 PUSHJ P,REALL1 ;%% PROCESS FOURTH ARG
73300 MOVE A,AR2A ;%%
73310 PUSHJ P,REALL1 ;%% PROCESS FIFTH ARG
73320 MOVE A,-4(P) ;%% PICK UP FWS INCREMENT
73330 ADD A,SFWS ;%% MAKE NEW TOTAL FWS
73340 IDIVI A,44 ;%% CALCULATE SPACE FOR BIT TABLE
73350 ADDI T,1(A) ;%% ADD TO TOTAL
73360 MOVEM T,(P) ;%% SAVE TOTAL (FS AMOUNT NOT NEEDED)
73370 PUSHJ P,EXCISE ;%% CLEAR BUFFERS, ETC.
73380 POP P,A ;%% GET TOTAL BACK
73390 SETZ D, ;%% CLEAR RELOCATION REGISTER
73400 ;%% (HERE WE GO AGAIN)
73410 PUSHJ P,MORCOR ;%% ALLOCATE THE ADDITIONAL SPACE
73420 MOVE B,SC2 ;%% CLEAR STACKS AND UNBIND VARIABLES
73430 PUSHJ P,UBD ;%%
73440 HRRZ B,.JBREL ;%% GET NEW HIGH LIMIT
73450 CAMGE B,JRELO# ;%% DID CORE GET SMALLER?
73460 HALT . ;%% YES -- WE QUIT
73470 MOVEM B,JRELO# ;%% RESET LIMIT
73480 HRLM B,.JBSA ;%%
73490 IFN ALVINE <
73500 MOVEI A,ED+2 ;%%INDICATE ED WAS OVERWRITTEN
73510 HRRM A,EDA ;%%SO THEY WILL BE RELOADED IF NEEDED
73520 >
73530 MOVE A,SFWS ;%% SAVE OLD VALUE
73540 MOVEM A,OSFWS ;%%
73550 MOVE A,FSO ;%%
73560 MOVEM A,OFSO ;%%
73570 POP P,A ;%% SPDL INCREMENT
73580 ADDM A,SSPDL ;%% CHANGE TOTAL
73590 MOVN AR2A,A ;%% SAVE JUST IN CASE
73600 POP P,A ;%% RPDL INCREMENT
73610 ADDM A,SRPDL ;%% CHANGE TOTAL
73620 MOVN AR1,A ;%% SAVE AGAIN
73630 POP P,A ;%% BPS TOTAL
73640 MOVEM A,FSMOVE ;%% HOW MUCH TO MOVE FS
73650 ADDM A,FSO ;%% NEW FS ORIGIN
73660 ADDM A,SBPS ;%% BPS INCREMENT
73670 POP P,A ;%% FWS INCREMENT
73680 ADDM A,SFWS ;%% ADD TO TOTAL
73690 JRST REALL2 ;%% JUMP INTO REGULAR ALLOCATOR
73700 ;%% (ALL DATA OFF STACK)
73710 >
73720
73730 ALLOC: MOVE B,SC2 ;** ACCUMS ARE OK IF HERE
73740 PUSHJ P,UBD ;** SO UNBIND VARS FIRST
73750 PUSHJ P,TTYRET ;** AND CLOSE ANY OPEN I/O CHANNELS
73760 INALLC: HRRZ A,.JBREL ;SEE IF CORE WAS EXPANDED
73770 CAMN A,JRELO# ;OR NOT
73780 JRST OUTALC ;NO EXPANSION - DON'T REALLOCATE
73790 CAMG A,JRELO# ;CHECK TO SEE IF IT GOT SMALLER!
73800 HALT ;YES - BITCH
73810 MOVEM A,JRELO# ;SAVE NEW CORE BOUND
73820 HRLM A,.JBSA
73830 IFN ALVINE,<
73840 MOVEI F,ED+2 ;INDICATE THAT ED WAS OVERWRITTEN
73850 HRRM F,EDA ;SO ED AND GRINDEF WILL BE READ IN IF NEEDED>
73860 INAGN: SETOM NOALIN# ;SET UP FOR AUTOMATIC ALLOCATION
73870 OUTSTR [ASCIZ /
73880 ALLOC? (Y OR N) /] ;ASK USER IF HE WISHES TO SET UP
73890 INCHRW C ;THE ALLOCATION INCREMENTS
73900 CAIE C,"Y" ;** ALLOW UPPER AND lower Y
73910 CAIN C,"y"
73920 SETZM NOALIN# ;SET FLAG TO PROMPT FOR ALLOCATIONS
73930 SETFWS: MOVE A,SFWS# ;SAVE OLD SIZE OF FWS
73940 MOVEM A,OSFWS#
73950
73960 SKIPN NOALIN ;SKIP QUESTIONS IF AUTOMATIC
73970 OUTSTR [ASCIZ /
73980 FULL WORD SP. = /]
73990 JSP R,ALLNUM
74000 JUMPN A,.+3
74010 SKIPE INITFW#
74020 ADDI A,440 ;INITIAL ALLOCATION FOR FWS
74030
74040 ADDM A,SFWS# ;ADD EITHER USER INCREMENT OR 0 TO SFWS
74050
74060 MOVE A,FSO# ;SAVE OLD FS ORIGIN
74070 MOVEM A,OFSO# ;FOR RELOCATION
74080
74090 SKIPN NOALIN ;SKIP IF USER DONE
74100 OUTSTR [ASCIZ /
74110 BIN. PROG. SP. = /]
74120 JSP R,ALLNUM
74130 JUMPN A,.+3
74140 SKIPE INITFW
74150 ADDI A,10 ;** MAKE SURE THERE'S A LITTLE BPS
74160 ADDM A,SBPS#
74170 MOVEM A,FSMOVE# ;THE INCREMENT TO SBPS IS THE AMOUNT BY
74180 ADDM A,FSO# ;THE FREE SPACE IS MOVED - UPDATE ORIGIN
74190
74200 SKIPN NOALIN ;SKIPIF USER DONE
74210 OUTSTR [ASCIZ /
74220 REG. PDL. = /]
74230 JSP R,ALLNUM
74240 JUMPN A,.+3
74250 SKIPE INITFW# ;CHECK IF INITIAL ALLOCATION
74260 ADDI A,1000
74270 ADDM A,SRPDL#
74280 MOVN AR1,A ;SAVE IN CASE OF OVERFLOW
74290
74300 SKIPN NOALIN ;SKIP IF USER DONE
74310 OUTSTR [ASCIZ /
74320 SPEC. PDL. = /]
74330 JSP R,ALLNUM
74340 JUMPN A,.+3
74350 SKIPE INITFW# ;CHECK FOR INITIAL ALLOCATION
74360 ADDI A,1000
74370 ADDM A,SSPDL#
74380 MOVN AR2A,A ;SAVE IN CASE OF OVERFLOW
74390 IFN HASH,<
74400 SKIPN INITFW
74410 SETOM NOALIN
74420 SKIPN NOALIN
74430 OUTSTR [ASCIZ /
74440 HASH = /]
74450 JSP R,ALLNUM
74460 CAIG A,BCKETS
74470 JRST OCR
74480 HRRM A,INT1
74490 MOVNS A
74500 HRRM A,RH4
74510 SETOM HASHFG>
74520 OCR: OUTSTR [ASCIZ /
74530 /]
74540 REALL2: MOVE A,JRELO# ;COMPUTE SIZE OF AVAILABLE CORE
74550 SUBI A,FS ;SO THAT EXTRA CORE CAN BE DISTRIBUTED
74560
74570 SUB A,SBPS ;TAKE OFF CORE ALLOCATED FOR BPS
74580 SUB A,SFS# ;TAKE OFF CORE IN PREVIOUS FS
74590 SUB A,SBT# ;AND ASSOCIATED BIT TABLE
74600 SUB A,SFWS ;TAKE OFF CORE NOW ALLOCATED TO FWS
74610 SUB A,SRPDL ;TAKE OFF CORE NOW ALLOCATED TO RPDL
74620 SUB A,SSPDL ;TAKE OFF CORE NOW ALLOCATED TO SPDL
74630
74640 MOVE F,SFWS ;ESTIMATE SIZE NEEDED FOR BTF
74650 IDIVI F,44
74660 ADDI F,1
74670 SUB A,F ;AND TAKE IT OFF TOTAL
74680 MOVEM F,SBTF# ;ALSO SAVE TO RESTORE LATER
74690 JUMPGE A,ALOK ;MAKE SURE NO OVERFLOW
74700 OUTSTR [ASCIZ /ALLOCATIONS ARE TOO LARGE
74710 /] ; IF SO THEN RETRY
74720 MOVE A,OSFWS
74730 MOVEM A,SFWS ;RESTORE SIZE OF FWS
74740 MOVN A,FSMOVE
74750 ADDM A,SBPS ;RESET SIZE OF BPS
74760 ADDM A,FSO ;AND FS ORGIN
74770 ADDM AR1,SRPDL ;RESET STACKS
74780 ADDM AR2A,SSPDL
74790 CLRBFI ;** CLEAR OUT ANY GARBAGE
74800 JRST INAGN
74810
74820 ALOK: MOVE B,A ;NOW CAN ALLOCATE EXCESS CORE
74830 ACHLOC: ASH B,-4 ;1/16 TO FWS
74840 ADDM B,SFWS
74850 SUB A,B ;TAKE IT OFF REMAINING CORE
74860 SKIPE INITFW
74870 SETZ B,
74880 ASH B,-4 ;1/64 TO PDLS
74890 ADDM B,SSPDL
74900 SUB A,B
74910 ADDM B,SRPDL
74920 SUB A,B ;AND TAKE IT OFF REMAINING CORE
74930
74940 MOVE T,SFWS ;CALCULATE ACTUAL SIZE OF BTF
74950 IDIVI T,44
74960 ADDI T,1
74970 ADD A,SBTF ;REMOVE ESTIMATED LOSS FOR BTF
74980 MOVEM T,SBTF
74990 SUB A,T ;AND TAKE OFF ACTUAL LOSS TO BTF
75000
75010 ADD A,SFS ;ADD BACK ON SPACE FROM OLD FS
75020 ADD A,SBT ;AND ASSOCIATED BT
75030 ;GIVING NEW SPACE AVAILABLE FOR
75040 ;FS AND BT
75050 MOVE TT,A
75060 IDIVI TT,41 ;SBS = SFS/32. = (SBS + SFS)/33.
75070
75080 ADDI TT,1
75090 MOVEM TT,SBT
75100
75110 SUB A,TT ;TAKE OFF SBT FROM REMAINING CORE
75120 MOVEM A,SFS ;GIVING AVAILABLE SFS
75130
75140 ;SET UP REGISTERS FOR GC ETC. SETUP
75150
75160 MOVE A,SFWS ;A ← SFWS
75170 MOVEI B,FS
75180 ADD B,SFS
75190 ADD B,SBPS ;B ← NFWSO (ORIGIN OF NEW FULL WORD SPACE)
75200 MOVE C,SRPDL ;C ← SRPDL
75210 MOVE F,OSFWS ;F ← OLD SIZE OF FWS
75220
75230 HRRM B,GCP1 ;GCP1 ← NFWSO
75240 MOVN SP,B ;-NEW BOTTOM OF FWS
75250
75260 HRRM SP,GCMFWS
75270 HRLZM A,C1GCS
75280 MOVNS C1GCS ;-NEW LENGTH OF FWS
75290 HRRM B,C1GCS ;HAVE FWS POINTER AND COUNT FOR SWEEP
75300
75310 ADD B,A ;NEW FIRST WORD OF BT (FS BIT TABLE)
75320
75330 MOVE SP,FSO ;SP ← NEW ORIGIN OF FS
75340
75350 LSH SP,-5
75360 SUBM B,SP ;NUMBER USED TO FIND BIT TABLE WORD
75370 HRRM SP,GCBTP1 ;FROM FS WORD ADDRESS
75380 HRRM SP,GCBTP2
75390
75400 HRLM B,C3GC ;BOTTOM OF BIT TABLES
75410 HRRM B,GCP2
75420 HRRM B,GCP ;(ALSO UPPER BOUND ON FWS AND FS)
75430
75440 MOVNI SP,-2(TT) ;-SIZE OF BT (TT = SBT)
75450 HRLM SP,C3GCS ;IOWD FOR BIT TABLE SWEEP
75460 HRRM B,C3GCS
75470 MOVE SP,FSO
75480 ANDI SP,37 ;MASK OUT ALL BU LAST FIVE BITS
75490 HRRM SP,GCBTL2 ;MAGIC NUMBER TO POSITION
75500 SUBI SP,40
75510 HRRM SP,GCBTL1
75520
75530 ADDI B,1 ;B ← B + 1
75540 HRRM B,C3GC ;BOTTOM OF FS BIT TABLE + 1
75550 ADDI B,-2(TT) ;GET BOTTOM OF BTF - 1, POINTER IS INCREMENTED
75560 HRRM B,C2GCS ;BEFORE USE
75570
75580 ADDI B,1 ;B ← B + 1
75590 HRRM B,C2GC ;BOTTOM OF FWS BIT TABLE + 1
75600 ADDI B,-1(T) ;SINCE T IS NOW SIZE OF BTF, NOT SBTF-1
75610
75620 HRRM B,GCP5 ;TOP OF BIT TABLES
75630 ADDI B,1 ;BOTTOM OF REG PDL
75640
75650 MOVE S,ATMOV ;## S NOT SET IF LISP STARTED WITH CORE
75660 ;## ALREADY EXPANDED, SO RESET IT
75670 HRRZI A,OBTBL(S) ;GET OBLIST POINTER
75680 ;## RHX2 NO LONGER PURE, WE WANT THE SYSTEM OBLIST
75690 ;## THIS IS IT (I HOPE)3/28/73
75700 ADD A,FSMOVE ;INCREMENT TO
75710 ;ACCOUNT FOR MOVE OF FS
75720 MOVEM A,(B)
75730 HRRM B,GCP3 ;ROOM FOR ACS DURING GC
75740 ADDI B,1 ;B ← B + 1
75750 HRRM B,GCSP1
75760 HRRM B,GCP4 ;ROOM FOR ACS
75770 ADDI B,10 ;B ← B + 10
75780 HRRM B,GCP41 ;TOP OF AC AREA
75790 ADDI B,1 ;B ← B + 1
75800 HRRM B,C2 ;SET UP RPDL POINTER
75810 MOVNI A,-20(C) ;A ← - (C -20) = -(SRPDL - 20)
75820 HRLM A,C2 ;THIS IS THE ACTUAL SIZE OF RPDL
75830 ;TAKING INTO ACCOUNT THE AC AREA
75840 ;** (AND SLOP AT TOP FOR ROOM TO
75850 ;** PRINT STACK OVERFLOW MSG)
75860
75870 HRRZ A,JRELO# ;TOP OF CORE - FOR SPDL PTR
75880
75890 MOVN B,SSPDL
75900 ADD A,B
75910 HRL A,B
75920
75930 MOVEM A,SC2# ;SET UP SPDL POINTER (I HOPE)
75940 MOVN A,A ;CREATE OFFSET FOR STACK POINTERS
75950 ADDI A,INUM0
75960 HRRZM A,SPNM#
75970 SETZM INITFW ;TURN OFF INITIAL ALLOCATION FLAG
75980
75990 ;RELOCATE THE FULL WORD SPACE
76000 ;GCP1 HOLDS POINTER TO ORIGIN OF NEW FWS
76010 ;FWSO# HOLDS POINTER TO ORIGIN OF OLD FWS
76020 ;AND F HOLDS SIZE OF OLD FWS (AMOUNT TO BE MOVED)
76030 MOVSI B,F
76040 HRR B,GCP1
76050 MOVE C,FWSO#
76060 HRRZI AR2A,-1(C) ;TAKE THE OPPORTUNITY TO GET ADDRESS
76070 ;OF END OF OLD FS (USED LATER)
76080 HRLI C,F
76090 MOVE A,@C ;GET WORD FROM END OF OLD FWS
76100 MOVEM A,@B ;AND MOVE TO END OF NEW FWS
76110 SOJGE F,.-2 ;F COUNTS DOWN WORDS IN OLDFWS
76120 ;END OF FWS RELOCATION
76130
76140 MOVE FF,FSMOVE ;GET FAST ACCESS TO RELOCATE SIZE FOR FS
76150 HRRZ F,AR2A
76160 ADD F,FF ;AND FIND WHERE TO PUT WORDS FROM
76170 ;END OF OLD FS IN NEW FS
76180
76190
76200 HRRZ AR1,GCP1 ;COMPUTE FWS RELOCATION CONSTANT
76210 SUB AR1,FWSO
76220
76230
76240 ;RELOCATE FS - ALSO RELOCATE ALL
76250 ;POINTERS TO FS AND TO FWS
76260
76270 REL1: HLRZ A,(AR2A) ;GET CAR POINTER OF OLD FS WORD
76280 JSP R,REL4
76290 HRLM A,(F) ;MOVE CAR TO NEW POSITION
76300 HRRZ A,(AR2A) ;GET CDR PTR
76310 JSP R,REL4 ;CHECK FOR FS RELOCATE
76320 HRRM A,(F)
76330 SUBI F,1 ;F ← F -1
76340 CAMLE AR2A,OFSO ;CHECK TO SEE IF DONE
76350 SOJA AR2A,REL1 ;NO - GO LOOP
76360 HRRZ A,GCMKL ;RELOCATE ARRAYS
76370 JSP R,REL4
76380 HRRZ D,A
76390 MOVEM D,GCMKL
76400 REL5: HLRZ AR2A,(D)
76410 MOVE AR2A,(AR2A)
76420 REL6: HLRZ A,(AR2A)
76430 JSP R,REL4
76440 HRLM A,(AR2A)
76450 HRRZ A,(AR2A)
76460 JSP R,REL4
76470 HRRM A,(AR2A)
76480 AOBJN AR2A,REL6
76490 HRRZ D,(D)
76500 JUMPN D,REL5
76510 SETZM BIND3 ;JUST IN CASE
76520 SKIPE INITF ;DON'T FORGET THE INITFN
76530 ADDM FF,INITF
76540 SKIPE INITF1 ;## DON'T FORGET THE INIT FILES
76550 ADDM FF,INITF1 ;##
76560 SKIPE NOUUOF ;RELOCATE FLAGS
76570 ADDM FF,NOUUOF
76580 IFN ALVINE<
76590 SKIPE BACTRF ;** ONLY IF ALVINING
76600 ADDM FF,BACTRF>
76610 SKIPE GCGAGV
76620 ADDM FF,GCGAGV
76630 SKIPE RSTSW
76640 ADDM FF,RSTSW
76650 SKIPE DDTIFG ;** RELOCATE DDT FLAG
76660 ADDM FF,DDTIFG ;**
76670 ; JRST RELFOO ;[UT]
76680
76690 RELFOO: MOVE S,SBPS ;S IS THE RELOCATOR FOR MOST MACRO
76700 MOVEM S,ATMOV ;REFERENCES TO ATOMS AND FS
76710 MOVE A,FSMOVE
76720 IFE OLDNIL< ADDM A,NILHD> ;## RESET NIL HEAD
76730 HRR B,VOBLIST(S) ;## GET CURRENT VALUE OF OBLIST
76740 HRRM B,RHX5 ;## RESET WORD THAT POSTINDEXES OFF B
76750 HRRM B,RHX2 ;## RESET WORD POSTINDEXING OFF C
76760 ADDM A,XXX3 ;## RESET WIERD CODE
76770 ADDM A,XXX4 ;## RESET UNBOUND
76780 ADDM A,XXX5 ;## RESET FS (SAME WORD AS FS),ALSO GCPP1
76790 MOVE A,GCP1
76800 HRRZM A,FWSO
76810 MOVE A,C3GCS
76820 HRRZM A,EFWSO#
76830 SETZB F,FF ;** CLEAR F TO FORCE GC
76840 MOVE SP,SC2 ;** INIT SPDL POINTER FOR UBD IN STRT
76850 MOVE P,C2 ;** INIT PDL POINTER
76860 MOVE A,VBPEND(S) ;** GET OLD BPEND
76870 PUSHJ P,NUMVAL ;** (FIXED FOR POSSIBLE NON-INUM)
76880 ADD A,FSMOVE ;** INCREMENT IT
76890 PUSHJ P,FIX1A ;** CONVERT IT BACK (CAN CAUSE GC)
76900 MOVEM A,VBPEND(S) ;** AND STORE IT
76910 OUTALC: PUSHJ P,IOBRST ;** CLEAR OUT ALL I/O CHANNELS
76920 JRST STRT
76930
76940 REL4: CAMGE A,EFWSO ;SEE IF BEYOND END OF FWS
76950 CAMGE A,OFSO ;OK - SEE IF MAYBE IN FS
76960 JRST (R)
76970 CAMGE A,FWSO ;SEE IF IN FWS
76980 JRST .+3
76990 ADD A,AR1 ;RELOCATE FWS POINTER
77000 JRST (R)
77010 ADD A,FF ;RELOCATE FS POINTER
77020 JRST (R)
77030 PAGE
77040 ;SUBROUTINE FOR NUMBER INPUT
77050 ;%% RETURNS 0 IF NOALIN # 0
77060 ;%% SETS NOALIN # 0 IF ALTMOD IS INPUT
77070 ;%% RETURNS 0 IF A BLANK IS INPUT
77080 ;%% IGNORES OTHER NON-NUMERIC CHARACTERS EXCEPT
77090 ;%% AS TERMINATORS OF NUMBERS
77100
77110 ALLNUM: SETZB A,ALLNM1# ;%% CLEAR A AND FIRST TIME FLAG
77120 SKIPE NOALIN#
77130 JRST (R)
77140 INCHRW C
77150 CAIN C,RUBOUT
77160 JRST [OUTSTR [ASCIZ /XXX /]
77170 JRST ALLNUM]
77180 CAIL C,"0"
77190 CAILE C,"9"
77200 JRST BANGCK
77210 SETOM ALLNM1# ;%% NOT FIRST TIME NOW
77220 ASH A,3
77230 ADDI A,-"0"(C)
77240 JRST ALLNUM+3
77250
77260 BANGCK: CAIE C,15 ;%% TERMINATE ON CR OR
77270 CAIN C,40 ;%% TERMINATE ON BLANK
77280 JRST (R) ;%%
77290 CAIN C,ALTMOD ;%% ALTMODE (TERMINATOR)?
77300 JRST [SETOM NOALIN#
77310 JRST (R) ] ;%% YES--TURN ON SWITCH AND RETURN
77320 SKIPE ALLNM1# ;%% IGNORE LEADING JUNK?
77330 JRST (R) ;%% NO--RETURN
77340 JRST ALLNUM+3 ;%% YES--LOOP
77350
77360 PAGE
77370
77380
77390
77400
77410 IFN HASH,<
77420 REHASH:
77430 MOVEI A,BFWS(S)
77440 PUSH P,A
77450 HRRM A,RHX2
77460 HRRM A,RHX5
77470 MOVS B,RH4#
77480 ADD B,S ;$$PUT IN ATOM MOVE OFFSET IN B, SINCE CAN'T
77490 ;$$DOUBLE INDEX - THIS REMOVES THE FOO PROBLEM
77500 ;$$IN THE NEXT THREE FOO'S
77510
77520 HRRZI A,BFWS+1(B)
77530 MOVEM A,BFWS(B)
77540 AOBJN B,.-2
77550 SETZM BFWS(B)
77560 MOVSI AR2A,-BCKETS
77570 HRR AR2A,S ;$$PUT IN ATOM MOVE OFFSET IN AR2A TO AVOID
77580 ;$$DOUBLE INDEXING WITH S IN REMOVING FOO
77590 ;$$PROBLEM
77600 RH1:
77610 HLRZ C,OBTBL(AR2A)
77620 RH3: JUMPE C,RH2
77630 HLRZ A,(C)
77640 PUSH P,C
77650 PUSH P,AR2A
77660 PUSHJ P,INTERN
77670 POP P,AR2A
77680 POP P,C
77690 HRRZ C,(C)
77700 JRST RH3
77710 RH2: AOBJN AR2A,RH1
77720 SETZM HASHFG
77730 POP P,A
77740 HRRM A,@GCP3
77750 MOVEM A,OBLIST(S)
77760 JRST STRT>
77770
77780 PAGE
77790 SUBTTL NEW FUNCTIONS TO MAKE USE OF MODIFIED SPECIAL PDL FOR ERRORS
77800
77810 ;$$ROUTINE TO GET POINTER TO SPDL AND MAKE IT INTO AN INUM
77820 SPDLPT: HRRZ A,SP ;$$CREATE A POINTER TO THE CURRENT TOP OF STACK
77830 ADD A,SPNM
77840 POPJ P, ;$$
77850
77860
77870 ;$$ROUTINE TO GET LEFT HAND SIDE OF SPDL ITEM INDICATED BY AN INUM FROM SPDLPT
77880 SPDLFT: SUB A,SPNM ;$$CONVERT TO ADDRESS
77890 HLRE A,(A) ;$$GET LEFT HAND ITEM
77900 JUMPL A,TRUE ;$$IF IT IS NEGATIVE IT CAME FROM A STACK
77910 ;$$POINTER AND WE RETURN T INSTEAD
77920 HRRZI A,(A) ;$$CLEAR OUT LEFT HAND OF AC
77930 POPJ P, ;$$RETURN - RETURNS NIL FOR LHS = 0
77940
77950 ;$$ROUTINE TO GIVE RIGHT HAND SIDE OF SPDL ENTRY SPECIFIED BY AN INUM FROM SPDLPT
77960 SPDLRT: SUB A,SPNM ;$$CONVERT TO AN ADDRESS
77970 HRRZ A,(A) ;$$ALL RHS ITEMS ARE LEGAL, NO NEED FOR CHECK
77980 POPJ P, ;$$
77990
78000 ;$$ROUTINE TO GET POINTER TO NEXT EVAL BLIP ON SPDL
78010 NEXTEV: SUB A,SPNM ;$$GET POINTER INSTEAD OF INUM
78020 HRRZ T,SC2 ;$$GET POINTER TO BOTTOM OF SPDL
78030
78040 SPDNLP: CAMG A,T ;$$CHECK IF HIT THE BOTTOM OF SPDL
78050 JRST FALSE ;$$RETURN NIL IF NO MORE INTERESTING WORDS
78060 HLL A,(A) ;$$TEST FOR WORD WITH 0 LHS
78070 TLZE A,-1 ;$$
78080 SOJA A,SPDNLP ;$$NOT AN INTERESTING WORD, LOOK AGAIN
78090 ADD A,SPNM ;$$FOUND AN INTERESTING WORD, CHANGE POINTER TO INUM
78100 POPJ P, ;$$
78110
78120
78130 ;$$ROUTINE TO EVALUATE A VARIABLE IN AN EARLIER CONTEXT
78140 ;$$ MORE EFFICIENT THAN EVAL WITH ALIST
78150 EVALV: MOVE C,A ;$$ MOVE AROUND FOR ATOM CHECK
78160 PUSHJ P,ATOM ;$$
78170 EXCH A,C ;$$
78180 SUB B,SPNM ;$$
78190 EVALV1: CAIL B,(SP) ;$$CHECK FOR END OF SPDL (** CH FRM CAIN)
78200 JRST GETV ;$$VARIABLE NOT REBOUND - GET CURRENT VALUE
78210 SKIPGE ,(B) ;$$CHECK TO AVOID SPDL POINTERS ON STACK
78220 AOJA B,EVALV1 ;$$
78230 HLRZ T,(B) ;$$T←CAR(B)
78240 SKIPE C ;$$
78250 HLRZ T,(T) ;$$GET CAR OF SPECIAL CELL - ATOM POINTER
78260 CAIE T,(A) ;$$COMPARE WITH ATOM TO BE EVALUATED
78270 AOJA B,EVALV1 ;$$NOT IT, LOOK SOME MORE
78280 HRRZ A,(B) ;$$GET VALUE FROM SPDL
78290 POPJ P, ;$$
78300
78310 GETV: JUMPE C,GETV1
78320 MOVEI B,VALUE(S) ;$$ATOM NOT REBOUND, VALUE THEN IS
78330 PUSHJ P,GET ;$$
78340 JUMPE A,UNBOND ;$$NOT BOUND AT ALL, GIVE UNBVAR MESSAGE
78350 GETV1: HRRZ A,(A) ;$$GET CDR OF SPECIAL CELL
78360 POPJ P, ;$$
78370
78380 UNBOND: HRRZI A,UNBOUND(S) ;$$RETURN ATOM UNBOUND
78390 POPJ P, ;$$
78400
78410 ;$$ROUTINE TO CLEAR SPECIAL PDL TO POSITION SPECIFIED BY INUM
78420 CLRSPD: MOVEI B,-2-INUM0(A) ;$$ -2 TO GET OVER EVAL BLIP
78430 HLRZ TT,SC2# ;$$GET REAL SPD POINTER WITH A LHS
78440 ADD TT,B ;$$FIND OUT HOW MANY WORDS ARE USED
78450 ADD B,SC2 ;$$
78460 HRL B,TT ;$$SET UP SPD POINTER
78470 JRST UBD ;$$UBD DOES ALL THE WORK
78480
78490 ;$$ROUTINE TO RETURN FROM SPECIAL PDL CONTEXT, SPECIFIED BY AN
78500 ;$$EVAL BLIP, WITH A GIVEN VALUE
78510 OUTVAL: PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL BLIP
78520 JUMPE A,FALSE ;$$ NO EVAL BLIP, RETURN NIL
78530 HRLZI C,(POPJ P,) ;$$ SET TYPE OF RETURN
78540 JRST SPRE1 ;$$ FINISH UP IN SPREDO
78550
78560
78570 ;$$ROUTINE TO RE-EVALUATE EXPRESSION FROM AN EVAL BLIP AND GO ON FROM
78580 ;$$ THAT CONTEXT (NOT A USER CALLABLE FUNCTION)
78590 REVAL1: HRRZ P,1(SP) ;$$ RPDL POINTER IS UP ONE
78600 HRRZ T,C2# ;$$
78610 HLRZ TT,C2# ;$$
78620 ADD TT,P ;$$
78630 SUB TT,T ;$$
78640 HRL P,TT ;$$
78650 DOSET: MOVE D,ERRTN ;$$ POP ERRSETS, LOAD CURRENT ERRSET
78660 SKIPE D ;$$DONE IF EMPTY
78670 CAMG D,P ;$$ COMPARE TO CURRENT RPDL
78680 XCT C ;$$ DONE, DO A STRANGE EXIT
78690 SUB D,[XWD 1,1] ;$$ GO DOWN A WORD
78700 POP D,ERRSW ;$$
78710 POP D,ERRTN ;$$
78720 JRST DOSET ;$$ TRY AGAIN
78730
78740
78750
78760 ;$$ROUTINE TO CLEAR SPD TO A GIVEN POINT AND REDO FROM THERE
78770 ;$$ A CONTAINS AN SPD INUM POINTER, FORCE IT TO BE EVAL BLIP POINTER
78780
78790 SPREDO: PUSHJ P,NEXTEV ;$$FORCE TO EVAL BLIP POINTER
78800 JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL BLIP
78810 MOVE B,A ;$$GET THE EXPRESSION
78820 SUB B,SPNM
78830 HRRZ B,(B)
78840 MOVE C,[JRST XXEVAL] ;$$SET RETURN (**Ch. from EVAL 4/24/77)
78850 SPRE1: PUSH P,B ;$$SAVE SPDL POINTER
78860 PUSHJ P,CLRSPD ;$$CLEAR OUT SPD - INCLUDES RESTORING PROGS
78870 POP P,A ;$$
78880 JRST REVAL1
78890
78900 ;$$ SPREVAL - SIMILAR TO OUTVAL BUT EVALUATES THE GIVEN VALUE
78910 ;$$AS OF THE SPECIFIED CONTEXT, EQUIVALENT TO:
78920 ;$$ (PROG2 (RPLACD (NUMVAL (SETQ A (NEXTEV A))) B) (SPREDO B))
78930 ;
78940 SPREVAL:PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL-BLIP
78950 JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL-BLIP
78960 JRST SPRE1-1 ;$$LET SPREDO FINISH UP
78970
78980
78990 ;$$COMPUTES A LISP POINTER TO A STACK ENTRY
79000 STKPTR: SUB A,SPNM
79010 POPJ P,
79020
79030 PAGE
79040 SUBTTL LISP ATOMS AND OBLIST
79050
79060 DEFINE MAKBUC (A,%B)
79070 <DEFINE OBT'A <%B=.>
79080 XWD %B,IFN <<BCKETS-1>-A>,<.+1>
79090 IF1 <%B=0>>
79100
79110 DEFINE ADDOB (A,C,%B)
79120 <OBT'A
79130 DEFINE OBT'A<%B=.>
79140 IF1 <%B=0>
79150 XWD C,%B>
79160
79170 DEFINE PUTOB (A,B)
79180 <ZZ==<ASCII |A|>←<-1>
79190 ZZ==-ZZ/BCKETS*BCKETS+ZZ
79200 ADDOB \ZZ,B>
79210
79220 DEFINE PSTRCT (A)
79230 <ZZ==[ASCII |A|]
79240 LENGTH(ZY,<A>)
79250 ZY==<ZY-1>/5
79260 Q1(ZY,ZZ)>
79270
79280 DEFINE Q1 (N,Z)<
79290 IFN N,<XWD Z,[Q1(N-1,Z+1)]>
79300 IFE N,<XWD Z,0>>
79310
79320 ;## ARGS ARE A=NAME, B=PROP NAME, C'A=THE PROPERTY, D=LABEL OF ATOM
79330 DEFINE MKAT (A,B,C,D)
79340 <XLIST
79350 IRP A< PUTOB A,.+1
79360 D XWD -1,.+1
79370 XWD B,.+1
79380 XWD C'A,.+1
79390 XWD PNAME,.+1
79400 XWD [PSTRCT(A)],0>
79410 LIST>
79420
79430 ;## ARGS ARE: D'A=PROPERTY, B=PROP NAME, C=NAME
79440 DEFINE MKAT1 (A,B,C,D)
79450 <XLIST
79460 IRP C <PUTOB C,.+1
79470 XWD -1,.+1
79480 XWD B,.+1
79490 XWD D'A,.+1
79500 XWD PNAME,.+1
79510 XWD [PSTRCT(C)],0>
79520 LIST>
79530
79540 DEFINE LENGTH (A,B)
79550 <A==0
79560 IRPC B,<A==A+1>>
79570
79580 ;## ATOM WITH SYM PROPERTY =V'ATOM LOCATION
79590 DEFINE ML1 (A)<IRP A,<
79600 XLIST
79610 V'A: XWD -1,.+1
79620 XWD FIXNUM,[A]
79630 MKAT A,SYM,V>
79640 LIST>
79650
79660 ;## SIMILAR TO ML1, EXCEPT %C=THE SYM PROP
79670 DEFINE MKSY1 (A,B,%C)<
79680 XLIST
79690 %C: XWD -1,.+1
79700 XWD FIXNUM,[A]
79710 PUTOB B,.+1
79720 XWD -1,.+1
79730 XWD SYM,.+1
79740 XWD %C,.+1
79750 XWD PNAME,.+1
79760 XWD [PSTRCT(B)],0
79770 LIST>
79780
79790 ;## ATOM WITH NO PROPS WITH LABEL SAME AS ATOM NAME
79800 DEFINE ML (A)<
79810 XLIST
79820 IRP A,<PUTOB A,.+1
79830 A: XWD -1,.+1
79840 XWD PNAME,.+1
79850 XWD [PSTRCT(A)],0>
79860 LIST>
79870
79880 ;## CREATE ATOM WITH NO LABEL OR PROPS. USED FOR COMMON ATMS IN SYSTEM
79890 DEFINE MK (A)<
79900 XLIST
79910 IRP A,<PUTOB A,.+1
79920 XWD -1,.+1
79930 XWD PNAME,.+1
79940 XWD [PSTRCT(A)],0>
79950 LIST>
79960
79970 ;** CREATE A STRING
79980 DEFINE MKSTR (A)<
79990 XLIST
80000 IRP A,<PUTOB A,.+1
80010 XWD -1,.+1
80020 XWD STRING,[PSTRCT(A)]>
80030 LIST>
80040 PAGE
80050 XALL
80060 RELOC
80070 VAR
80080 FS:
80090 OBTBL:
80100 OBLIST: ZZ==0
80110 XLIST ;(** MAKE THE HASH BUCKETS)
80120 REPEAT BCKETS,<MAKBUC \ZZ
80130 ZZ==ZZ+1>
80140 LIST
80150
80160 ;## GENERATE # FNS ONLY IF NONUSEFUL VALUES DESIRED
80170 IFN NONUSE<
80180 MKAT1 MEMBR.,SUBR,MEMBER#
80190 MKAT1 MEMB,SUBR,MEMQ#
80200 MKAT1 AND.,FSUBR,AND#
80210 MKAT1 OR.,FSUBR,OR#
80220 >
80230 MKAT<RPLACA,RPLACD,MINUS,TERPRI,CAR,CDR,CAAR>,SUBR
80240 MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
80250 MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
80260 MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
80270 MKAT<ATOM,PATOM,EQ,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
80280 MKAT<GCGAG,CHRCT,LINELENGTH,NUMBERP,EQUAL,GET,INTERN,MEMBER>,SUBR
80290 MKAT<LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
80300 MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
80310 MKAT<GCTIME,REVERSE,SPEAK,GC,GETL,MEMQ>,SUBR
80320 MKAT<PUTPROP,PRINC,FLATSIZE,ERR,EXAMINE,DEPOSIT,LSH>,SUBR
80330 MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP>,SUBR
80340 MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMAINDER,ABS>,SUBR
80350 MKAT<PROG1,LITATOM,NTHCHAR>,SUBR
80360 MKAT1 STRNGP,SUBR,STRINGP
80370 IFN SPRNT,<MKAT<SPRINT>,SUBR>;**
80380 IFN STPGAP,<MKAT<PGLINE>,SUBR>
80390 ;** LABEL ON PRIN1 FOR %PRINFNTOP
80400 MKAT PRIN1,SUBR,,PRINAT:
80410 MKAT EXPLODEC,SUBR,%
80420 MKAT TAB,SUBR,.
80430 MKAT TYO,SUBR,I
80440 MKAT TYI,SUBR,I
80450 CEVAL=.+1
80460 MKAT1 EVAL,SUBR,*EVAL
80470
80480 ;$$ REDEF. FOR NEW MAP FUNCTIONS
80490 MKAT<MAPCAN,MAPCON,MAPLIST,MAPCAR,MAP,MAPC>,LSUBR
80500 ;$$ GIVE MAPCAN THE DOUBLE NAME MAPCONC
80510 MKAT1 MAPCAN,LSUBR,MAPCONC
80520
80530 MKAT PROG,FSUBR,,PROGAT:
80540
80550 ;##LIST STARTS HERE
80560 MKAT LIST,FSUBR,,LISTAT:
80570
80580 MKAT <PROGN,COND,SETQ,INPUT,OUTPUT,SETSYS>,FSUBR
80590 IFN ALVINE,<MKAT<GRINDEF>,FSUBR
80600 MKAT<ED,BAKGAG>,SUBR>
80610 MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
80620 MKAT<AND,DEFPROP,CSYM,EXARRAY>,FSUBR
80630 MKAT1 QUOTE,FSUBR,FUNCTION
80640 MKAT1 %CLRBFI,SUBR,CLRBFI
80650 MKAT1 .ERROR,SUBR,ERROR
80660 MKAT1 LINRD,SUBR,LINEREAD
80670 MKAT1 UNBOND,SUBR,UNBOUND
80680 MKAT1 ECHO,SUBR,TTYECHO
80690 MKAT1 FUNCT,FSUBR,*FUNCTION
80700 MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR
80710
80720 ;## LABELS ON READ AND LISP EVAL FOR BOOTS
80730 MKAT READ,SUBR,,READAT:
80740 MKAT EVAL,LSUBR,O,EVALAT:
80750 MKAT ASCII,SUBR,A
80760 MKAT QUOTE,FSUBR,,CQUOTE:
80770 MKAT INUM0,SYM
80780
80790 PUTOB T,.+1
80800 TRUTH: XWD -1,.+1
80810 XWD VALUE,.+1
80820 XWD VTRUTH,.+1
80830 XWD PNAME,.+1
80840 XWD [PSTRCT(T)],0
80850 VTRUTH: TRUTH
80860
80870 PUTOB NIL,0
80880 FAKNIL: XWD -1,.+1 ;** FAKE NIL ATOM HEADER FOR ACCESSING PRP LST
80890 CNIL2: XWD VALUE,.+1
80900 XWD VNIL,.+1
80910 XWD PNAME,.+1
80920 XWD [PSTRCT(NIL)],0
80930 VNIL: NIL
80940
80950 MKSY1 %LCALL,*LCALL
80960 MKSY1 %AMAKE,*AMAKE
80970 MKSY1 %UDT,*UDT
80980 MKSY1 .MAPC,*MAPC
80990 MKSY1 .MAP,*MAP
81000 MKAT1 %NOPOINT,VALUE,*NOPOINT
81010 %NOPOINT: NIL
81020
81030 UNBOUND: XWD -1,.+1
81040 XWD PNAME,.+1
81050 XWD [PSTRCT(UNBOUND)],0
81060
81070 MKAT1 EXPN1,SUBR,*EXPAND1
81080 MKAT1 EXPAND,SUBR,*EXPAND
81090 MKAT1 PLUS,SUBR,*PLUS,.
81100 MKAT1 DIF,SUBR,*DIF,.
81110 MKAT1 QUO,SUBR,*QUO,.
81120 MKAT1 TIMES,SUBR,*TIMES,.
81130 MKAT1 APPEND,SUBR,*APPEND,.
81140 MKAT1 RSET,SUBR,*RSET,.
81150 MKAT1 GREAT,SUBR,*GREAT,.
81160 MKAT1 LESS,SUBR,*LESS,.
81170 MKAT1 PUTSYM,SUBR,*PUTSYM
81180 MKAT1 GETSYM,SUBR,*GETSYM
81190 MKAT1 RPTSYM,SUBR,*RPUTSYM
81200 MKAT1 RGTSYM,SUBR,*RGETSYM
81210
81220 ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>
81230
81240 PUTOB NUMVAL,.+1
81250 XWD -1,.+1
81260 XWD SUBR,.+1
81270 XWD NUMVAL,.+1
81280 XWD SYM,.+3
81290 XWD FIXNUM,[NUMVAL]
81300 XWD -1,.-1
81310 XWD .-1,.+1
81320 XWD PNAME,.+1
81330 XWD [PSTRCT(NUMVAL)],0
81340
81350 MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V
81360
81370 ;## QUEUE ATOMS AND OTHER NEW FNS.
81380
81390 MKAT<GTBLK,ERRCH,RDNAM>,SUBR
81400 MKAT<INUMP,NUMTYPE>,SUBR
81410 MKAT<UFDINP,RDFILE,MYPPN,BLKLST>,SUBR
81420 MKAT<RENAME,DELETE,INITFL>,FSUBR
81430 IFN QALLOW< ;%% [1]
81440 ML<DISP,CPU,FORMS,LIMIT,COPIES>;;##
81450 MKAT<QUEUE>,FSUBR; ;##
81460 > ;%% [1]
81470 MKAT1 ISFILE,SUBR,LOOKUP
81480
81490 IFN QALLOW< ;%% [1]
81500 ;## MOST OF THE EXTENDED SWITCHES (NOT ALL)
81510 IFN QSWEXT<
81520 ML<DEAD,AFTER>
81530 ML<MODIFY,KILL,.JB,DEPND,UNIQUE>
81540 ML<PAGES,PLOT,PTAPE,CARD,SEQ,PRIOR,SPACE,LIMIT,HEAD>
81550 > ;##END OF EXTENDED SWITCHES
81560 > ;%% END OF QALLOW CONDITIONAL [1]
81570
81580 ;$$ATOMS FOR DEFINITIONS OF FUNCTIONS FOR NEW SPDL PACKAGE
81590
81600 ML ERRORX
81610 MKAT1 INTPRP,SUBR,INITPROMPT
81620 MKAT1 STRT,FSUBR,**TOP**
81630 MKAT<PROMPT,READP,UNTYI,STKPTR,SPREDO,SPREVAL>,SUBR
81640 MKAT<MEMB,NEXTEV>,SUBR
81650 MKAT<SPDLFT,SPDLRT,SPDLPT>,SUBR
81660 MKAT<EVALV,OUTVAL>,SUBR
81670
81680 IFN REALLC <
81690 ;%% NEW DYNAMIC REALLOCATION FUNCTION
81700 MKAT1 REALLO,SUBR,REALLOC
81710 MKAT<FWCNT,FSCNT>,SUBR
81720 >
81730
81740 ;$$ MORE EXTENSIONS INCLUDING READ MACROS
81750 ML READMACRO
81760 MKAT1 %FLATSIZEC,SUBR,FLATSIZEC
81770 MKAT <NEQ,CONSP,CHRVAL,SETCHR,MODCHR,LEXORDER>,SUBR
81780 MKAT <FREE,FREELIST,SYSCLR,HGHCOR,HGHORG,HGHEND>,SUBR
81790 MKAT1 FALSE,FSUBR,SPECIAL
81800 MKAT1 FALSE,FSUBR,NOCALL
81810 MKAT1 FALSE,FSUBR,DECLARE
81820 MKAT1 FALSE,FSUBR,NILL
81830 MKAT1 APPLY.,SUBR,APPLY#
81840 MKAT1 .MAX,SUBR,*MAX
81850 MKAT1 .MIN,SUBR,*MIN
81860
81870 ;[UT] NEW FUNCTIONS FROM TEXAS
81880 IFN RANDOM,<
81890 MKAT1 GTOPOS,SUBR,UGETO
81900 MKAT1 GTIPOS,SUBR,UGETI
81910 MKAT1 SETPOS,SUBR,USETI
81920 >
81930 IFN SFDFLG,<
81940 MKAT PATH,FSUBR
81950 MKAT SCAN,SUBR
81960 >
81970
81980 ;** NEW RUTGERS FUNCTIONS
81990 MKAT1 DOEXIT,SUBR,EXIT
82000 MKAT1 TTYCLR,SUBR,TALK
82010 MKAT1 GETICH,SUBR,INCH
82020 MKAT1 GETOCH,SUBR,OUTCH
82030 MKAT <DTIME,EQSTR,EDITCH,CHRPOS,LINES,IASCII,ANTHCHAR>,SUBR
82040 MKAT PRINTC,SUBR,,CPRINTC:
82050 MKAT1 DODATE,SUBR,DATE
82060 MKSY1 ERRST1,*ERRSET1
82070 MKSY1 ERRST2,*ERRSET2
82080 MKAT1 .NCONC,SUBR,*NCONC
82090 MKAT1 AP2,SUBR,*APPLY
82100 MKAT <DEFLIST,DEFP,DEFV>,FSUBR
82110 MKAT1 RERDCH,SUBR,REREADCH
82120 MKAT1 PROGN,FSUBR,NOCOMPILE
82130 MKAT1 AEXPLD,SUBR,AEXPLODE
82140 MKAT1 %AEXPLD,SUBR,AEXPLODEC
82145 MKAT1 RDFILN,SUBR,RDFILENAM
82150 ML <EDITEXPR,INUM,STRING>
82160 CDEVPPN=.+1
82170 MK DEVPPN
82180 MKAT1 INTSTR,VALUE,INTERNSTR
82190 MKAT1 VPRNFN,VALUE,%PRINFNTOP
82200 MKAT1 RAISEV,VALUE,*RAISE
82210 MKAT1 VFLPRO,VALUE,FILPRO
82220 MKAT1 ERINT,VALUE,↑H
82230 MKAT1 UNBRKS,VALUE,UNBREAKABLEFNS
82240 PUTOB MACROEXPANSION,.+1
82250 MACEXP: XWD -1,.+1
82260 XWD FSUBR,.+1
82270 XWD DOMACX,.+1
82280 XWD VALUE,.+1
82290 XWD VMACEX,.+1
82300 XWD PNAME,.+1
82310 XWD [PSTRCT(MACROEXPANSION)],0
82320 INTSTR: NIL
82330 VFLPRO: NIL
82340 VMACEX: NIL
82350 VPRNFN: PRINAT
82360 RAISEV: NIL
82370 ERINT: NIL
82380 UNBRKS: NIL
82390
82400 ;$$ THE BREAK VARIABLES WHICH TELL ABOUT DEPTH IN THE BREAK PACKAGE
82410 ;** (#%IOCHANS%# and #%PROMPTS%# removed)
82420 MKAT1 BKSAVE,VALUE,#%BKSAVE
82430 MKAT1 BINDNT,VALUE,#%INDENT
82440 BKSAVE: NIL
82450 BINDNT: INUM0
82460
82470 VOBLIST: OBLIST
82480 VBASE: 8+INUM0
82490 VIBASE: 8+INUM0
82500
82510 ML <PNAME,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,SYM,∨
82520 $EOF$,LABEL,FUNARG,LSUBR,MACRO>
82530
82540 PUTOB ?,.+1
82550 QST: XWD -1,.+1
82560 XWD PNAME,.+1
82570 XWD [PSTRCT(?)],0
82580
82590 VBPORG: INUM0
82600 VBPEND: INUM0
82610
82620 ;MKAT ACHLOC,SYM
82630 ;DONT KNOW WHATS UP HERE, IF NEEDED CHECK ACHLOC
82640 ;%% THIS WAS A PREDECESSOR TO THE FUNCTIONS UNDER SWITCH "REALLC"
82650 ;%% NO LONGER USEFUL
82660
82670 PAGE
82680 ;
82690 ;** ALL THE ATOMS IN COMPILED LISP ROUTINES
82700 ;** (GETS PNAMES INTO HI SEG)
82710
82720 IFN PNAMES < ;** OFF TO BUILD A STRIPPED SYSTEM.
82730
82740 MK<<>,XTR,E:,EDITXTR,BRKWHEN,ENTER,F:,BKPOS,PPCOM,EXPBPS,SUBLIS,DO!L>
82750 MK<HLRZ@,MOVEI,UNFIND,UNBLOCK,GRINPROPS,MISER,NOTANY,MCONS,JUMPE>
82760 MK<MAXLOOP,F=,STKNAME,INSERT,Functions-Loaded,TIMER,DSUBST,LPTLENGTH>
82770 MK<UPFINDFLG,UNDOLST,PREVEV,SUBSET,INTERSECTION,TIMES,COMSQ,RETFROM>
82780 MK<EXTRACT,MOVEM,LASTPOS,STKCOUNT,USERERRORX,NOPRETTYPROPS,PRINLEV>
82790 MK<AROUND,PRINLC,PRINL,RGETSYM,HRRZ@,BF,PPMAXLEN,EXPFS,REMPROPS>
82800 MK<DSKOUT,DE,FORMS:,LESSP,DF,P:,BI,<P;>,REMOVE,MOVNI,LSUBST,UNION>
82810 MK<DO!V,JUMPN,PUSHJ,LASTVALUE,UNTRACEV,UNTRACE,EXPFWS,GE,LASTWORD,BK>
82820 MK<LEXPR,N?,EVERY,USERMACROS,BRKTYPE,SPRINT,MBD:,GETSYM,UNTIL>
82830 MK<NOTEVERY,LC,IF,PRINTLEV,PRINTMACRO,UNSAVE,HLLZS@,START,V:,PUTLIST>
82840 MK<BO,PRETTYPROPS,PRETTYFLG,DM,LE,CAIE,SUBSTRING,SUBST,DO,THROUGH>
82850 MK<QUOTIENT,LI,FP,broken,STKNTH,THROW,IN,CAME,FUNTYPE,FS,STKSRCH,OK>
82860 MK<DV,TTYIN,RI,LO,BY,GT,HRRZS@,CAIN,LP,SURROUND,EX,CALL,DSK:,ON,BIND>
82870 MK< ,DECR,CAMN,PP,RPUTSYM,LT,RO,MV,TO,TTYMSG,UP,HERE,&,NX,DIRF>
82880 MK<**EDITOR**,EDIT,TTYOUT,PUTSYM,<PPL;>,EXCH,*,BKEV,%%GCTIME,LSP:,SW>
82890 MK<BKFV,+,MAPL,<\P>,%%DTIME,MARK,-,INCR,ARGS,:::,**BREAK**,/>
82900 MK<File-Dumped,SAVE,$%DOTFLG,FNTH,SOJE,%%SPEAK,COMS,TDZA,FROM,SOME>
82910 MK<%%TIME,UNDO,MOVE,PLEV,%DO,:,LISP,LXPD,POPJ,<;>,PRIN,HRRM,SOJN,COPY>
82920 MK<TTY:,=,↑↑,WITH,*ANY*,←←,TYOA,%DEFINE,@,None-Found,A,B,PUSH,TEST>
82930 MK<%CATCH,HLRZ,C,%READIN,TYPE,D,E,THRU,JRST,##,F,RPTN,PLUS,%DEREAD>
82940 MK<!NX,STOP,HRRZ,I,RPTQ,SORT,ADD,/BREAK1,L,M,F:L,N,P,!0,Q,R,*RENAME,S>
82950 MK<not,BKE,#1,MBD,BKF,#2,EDIT-SAVE,#3,%DEVP,X,!UNDO,BFP,Y,--,*EXPAND2>
82960 MK<Z,!VALUE,*RAISEDSK,EDIT4E,<\>,LCL,%LOOKDPTH,<PP;>,PP-LABELS,LAP,↑>
82970 MK<EMBED,←,QBK,%PRINFN,FILBAK,FILBAKBAK,DIR,DIFFERENCE,INI,PP-COMMENT>
82980 MK<EDIT:,PP-DO,LABELS,CHANGE,%PREVFN%,CALLF@,BKV,DRM,PP-FORMAT,CALLF>
82990 MK<=EDITV,%TRSET,%TRSETQ,PP-MISER,DSM,CATCH,BRACKETS,MIN,MAKEFN>
83000 MK<PP-VALUE,CONCAT,BREAK1,BREAKIN,BREAK0,BREAKMACROS,LDIFF,BREAK,MAX>
83010 MK<ORF,JCALL,MSG,FOR,*NOPOINTDSK,INP,JCALLF@,JCALLF,CLEARM,MEMBFN>
83020 MK<Redefined,CLEARB,*RSETERX,PEEKC,READL,SUB,NTH,EDITCOMSL,GETDEF,NEX>
83030 MK<EDITDSUBST,ALIAS,*PG*,REPACK,BLOCK,EDITE,DELIM,PPL,=0,ADDPROP,JSP>
83040 MK<EDITFPAT,EDITFINDP,LPQ,SELECTQ,EDITF,EDITFNS,FNDBRKPT,USE,SPACES>
83050 MK<PP-RMACS,PP-LSEG,ALLFNS,BKFNLIST,ATTACH,MAPCL,POP,BEFORE,LSP>
83060 MK<%UNTRACE,HGHIN,TRACEVFNS,TRACEVed,TRACEV,TRACE,LCONC,TRACEDFNS>
83070 MK<BRKAPPLY,ALLVALS,-IN-,PP-SPECIAL,MERGE,COMMENTFLG,BRKCOMS,COMMENT>
83080 MK<COMMENTSTR,NCONC1,ORR,EDITL0,AFTER,::,EDITL,UNDEF,+I,EDITMV,HRLM@>
83090 MK<EDITMBD,EDITMACROS,BROKENFNS,ERXACTION,BROKEN-IN,FROM?=,MAPATOMS>
83100 MK<DSKLENGTH,BRKFN,GREATERP,REPLACE,NAMESCHANGED,GRINDEF,UNMACEXPAND>
83110 MK<<;;>,Files-Loaded,-I,LAPKLST,EDITOPS,LASTAIL,EDITOF,RPT,EDITPLEV>
83120 MK<EDITP,DREVERSE,CONSCOUNT,UNPACKSTRING,UNPACK,MAXLEVEL,TCONC,EDITQF>
83130 MK<MARKLST,DREMOVE,DUMPATOMS,SECOND,==,EDITRACEFN,BOUNDP,PUT,BELOW>
83140 MK<BKSET,HRRM@,BKSETQ,DSKIN,{,REMLIST,ASSOC#,WHILE,TAILP,PRINA,PRINAC>
83150 MK<?=,LAPQLST,THIRD,SUBPAIR,??,UNBREAK0,UNBREAK,BRKEXP,EDITV,ARGPRINT>
83160 MK<GRINL,UNBREAK!,LAPSLST,LAPLST>
83170 MKSTR< ?,Arguments not found., is being unbroken.,Enter >
83180 MKSTR<No Backup: ,MAXLOOP Exceeded>
83190 MKSTR<FSUBR -- Takes exactly one argument.,Nothing Saved, ...]>
83200 MKSTR< is not a breakable function.>
83210 MKSTR<Should be a list of atomic arguments.,Should be a list.>
83220 MKSTR<STRING TOO SHORT - SUBSTRING, not found in >
83230 MKSTR< not in Symbol Table.,Not Blocked, Redefined., to ,<(>,<)>>
83240 MKSTR<BAD ARGUMENT - LCONC,BAD ARGUMENT - TCONC,... , Occurrences>
83250 MKSTR<BAD FORMAT - DO, Broken:, Undone,< msec clock, >,< msec GC), >>
83260 MKSTR<< msec CPU (>,Set ,CAN'T INSERT INTO ATOM,CAN'T ATTACH TO ATOM>
83270 MKSTR< argument list? ,NOT A TAIL - LDIFF, conses,*COMMENT*>
83280 MKSTR<not editable., unbreakable unless IN something.>
83290 MKSTR<NO EVAL BLIP - RETFROM,<\#\>,= , ,Different expression,! >
83300 MKSTR<*WARNING - NOCALL Function ,NON-NULL TAIL - SUBSET>
83310 MKSTR<NON-NULL TAIL - EVERY/SOME,- Location Uncertain,Blocked, . >
83320 MKSTR<BINARY PROGRAM SPACE EXCEEDED,<ILLEGAL FORMAT - DE, DF, DM>>
83330 MKSTR< Not Yet Defined.,MAXLEVEL Exceeded, can't be broken into., = >
83340 MKSTR< has no properties on PRETTYPROPS.>
83350 >
83360
83370 BFWS:
83380 EFWS: 0
83390 RELOC
83400 XLIST ;** LITERALS (INCLUDING HI-SEG FWS) ARE HERE
83410 LIT
83420 LIST
83430 BHORG: 0
83440 RELOC
83450 PAGE
83460 SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY)
83470
83480
83490 FIRST: CLEARM 0,SBPS ;SET UP INITIAL ALLOCATIONS FOR SPACE
83500 HRRZI A,BFWS-FS ;THIS IS THE SIZE OF THE ORIGINAL FS
83510 HRRZM A,SFS
83520 HRRZI A,EFWS-BFWS ;THIS ALLOWS ONLY THE INITIAL
83530 HRRZM A,SFWS ;FWS
83540 HRRZI A,0 ;THE INITIAL ALLOCATION FOR SPDL
83550 HRRZM A,SSPDL
83560 HRRZM A,SRPDL ;AND FOR RPDL IS SET UP IN INALLC
83570 HRRZI A,FS
83580 HRRZM A,FSO ;THIS SETS UP INITIAL FS POINTER
83590 HRRZI A,BFWS ;THIS SETS UP INITIAL FWS ORIGIN POINTER
83600 HRRZM A,FWSO#
83610
83620 HRRZI A,EFWS
83630 HRRZM A,EFWSO#
83640
83650
83660 MOVEI A,FS
83670 ADDM A,VBPORG ;SET UP VARIABLE FOR BPS ORIGIN
83680 SOS A
83690 ADDM A,VBPEND
83700
83710 MOVE A,.JBREL
83720 HRLM A,.JBSA
83730 CALLI RESET
83740 MOVEI A,START
83750 HRRM A,.JBSA ;SET STARTING ADDR
83760 HRRZS .JBHRL ;** SET TO SAVE ENTIRE HI-SEG
83770
83780 SETOM INITFW# ;FLAG FOR STANDARD INITIALIZATION OF
83790 SETZM JRELO# ;SIZES, AND TO INDICATE CORE WAS EXPANDED
83800
83810 JRST INALLC
83820 PAGE
83830 SUBTTL INTERNAL SYMBOLS FOR MACRO REFERENCES
83840
83850
83860 DEFINE MKENT (A)<
83870 INTERNAL A>
83880 ;##DEBUG QUEUE
83890 MKENT <CADAR,ATMOV,CADAR,CORUSE,DEV>
83900 IFN QALLOW< ;%% [1]
83910 MKENT <COPIES> ;%% [1]
83920 > ;%% [1]
83930 MKENT <EXT,HGHDAT,INUM0,INUMIN,IOPPN,LISTAT,MORCOR,MOVDWN>
83940 MKENT <NXTIO,OLDCU,SIXMAK,STNIL>
83950
83960 IFN BIGNMS<
83970 MKENT <EVBIG,NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,FIX2,NUM1,NUM3,BPR>>
83980 MKENT <OPR,FLOOV,FWCONS,FALSE,TRUE,FW0CNS,NCONS>
83990 MKENT <READ,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL>
84000 MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
84010 MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
84020 MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
84030 MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
84040 MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
84050 MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,STRT>
84060 MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>
84070 IFN ALVINE,<MKENT<PSAV1,BKTRC>>
84080
84090 ;%% RECENT ADDITIONS
84100 MKENT <FLTYIA,SIXATM,BNINIT,RDFILE,UFDINP,MYPPN>
84110 IFN QALLOW< ;%% [1]
84120 MKENT <QUEUE> ;%% [1]
84130 > ;%% [1]
84140 MKENT <SYSIN0,SYSIN1,SYSINI,SYSINP>
84150 IFN REALLC <
84160 MKENT <FWCNT,FSCNT,REALLO>
84170 >
84180
84190 ;$$ FOR ALAN'S DIRECT ACCESS INPUT
84200 MKENT <ININBF,TYI2,TYIA,INCH>
84210
84220 ;## FOR BILL'S DIRECT ACCESS INPUT/OUTPUT
84230 MKENT <AIN.2,AIN.4,AIN.7,AOUT.2,CHANNE>
84240 MKENT <CHNSUB,CHTAB,DEVDAT,ENTR,IOSUB>
84250 MKENT <LOOKIN,OUTCH,OUTERR,POPAJ,PPN,SMAC>
84260 MKENT <TABSR1,TABSRC,TYI2E,TYI2Z,TYI3B,TYO2X>
84270 MKENT <TYO5,AIOP,SETIN>
84280
84290 ;$$ FOR ALVINE
84300 MKENT <PROMPT,INUM0,MEMQ,UNBOUND>
84310
84320 ;%% FOR THE MODIFIED ARITHMETIC PACKAGE
84330 MKENT <FIXNUM,FLONUM>
84340
84350 PAGE
84360 END FIRST
84370